refactor: remove course-participant-field, course-application-field
This commit is contained in:
Gregor Kleen
parent
dcb83d96fc
commit
4f9a4f7f44
@ -56,7 +56,7 @@ CourseParticipant -- course enrolement
|
||||
course CourseId
|
||||
user UserId
|
||||
registration UTCTime -- time of last enrolement for this course
|
||||
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
|
||||
field StudyFeaturesId Maybe MigrationOnly
|
||||
allocated AllocationId Maybe -- participant was centrally allocated
|
||||
state CourseParticipantState
|
||||
UniqueParticipant user course
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
CourseApplication
|
||||
course CourseId
|
||||
user UserId
|
||||
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
|
||||
field StudyFeaturesId Maybe MigrationOnly
|
||||
text Text Maybe -- free text entered by user
|
||||
ratingVeto Bool default=false
|
||||
ratingPoints ExamGrade Maybe
|
||||
|
||||
@ -44,7 +44,6 @@ data ApplicationFormView = ApplicationFormView
|
||||
|
||||
data ApplicationForm = ApplicationForm
|
||||
{ afPriority :: Maybe Natural
|
||||
, afField :: Maybe StudyFeaturesId
|
||||
, afText :: Maybe Text
|
||||
, afFiles :: Maybe FileUploads
|
||||
, afRatingVeto :: Bool
|
||||
@ -118,12 +117,6 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
(False, _ , _ , _ )
|
||||
-> pure (FormSuccess Nothing, Nothing)
|
||||
|
||||
(fieldRes, fieldView') <- if
|
||||
| afmApplicantEdit || afmLecturer
|
||||
-> mreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (courseApplicationField . entityVal <$> mApp)
|
||||
| otherwise
|
||||
-> mforced (studyFeaturesFieldFor Nothing True (maybeToList $ mApp >>= courseApplicationField . entityVal) $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (mApp >>= courseApplicationField . entityVal)
|
||||
|
||||
let textField' = convertField (Text.strip . unTextarea) Textarea textareaField
|
||||
textFs
|
||||
| is _Just courseApplicationsInstructions
|
||||
@ -216,7 +209,6 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
|
||||
return ( ApplicationForm
|
||||
<$> prioRes
|
||||
<*> fieldRes
|
||||
<*> textRes
|
||||
<*> filesRes
|
||||
<*> vetoRes
|
||||
@ -226,8 +218,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
, ApplicationFormView
|
||||
{ afvPriority = prioView
|
||||
, afvForm = catMaybes $
|
||||
[ Just fieldView'
|
||||
, textView
|
||||
[ textView
|
||||
, filesLinkView
|
||||
, filesWarningView
|
||||
] ++ maybe [] (map Just) filesView ++
|
||||
@ -274,7 +265,6 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
appId <- insert CourseApplication
|
||||
{ courseApplicationCourse = cid
|
||||
, courseApplicationUser = uid
|
||||
, courseApplicationField = afField
|
||||
, courseApplicationText = afText
|
||||
, courseApplicationRatingVeto = afRatingVeto
|
||||
, courseApplicationRatingPoints = afRatingPoints
|
||||
@ -303,8 +293,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
|
||||
oldApp <- get404 appId
|
||||
let newApp = oldApp
|
||||
{ courseApplicationField = afField
|
||||
, courseApplicationText = afText
|
||||
{ courseApplicationText = afText
|
||||
, courseApplicationRatingVeto = afRatingVeto
|
||||
, courseApplicationRatingPoints = afRatingPoints
|
||||
, courseApplicationRatingComment = afRatingComment
|
||||
@ -323,8 +312,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
]
|
||||
|
||||
appChanged = any (\f -> f oldApp newApp)
|
||||
[ (/=) `on` courseApplicationField
|
||||
, (/=) `on` courseApplicationText
|
||||
[ (/=) `on` courseApplicationText
|
||||
, \_ _ -> not $ Set.null changes
|
||||
]
|
||||
|
||||
|
||||
@ -33,18 +33,11 @@ type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplic
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
|
||||
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
||||
, Entity User
|
||||
, Bool -- hasFiles
|
||||
, Maybe (Entity Allocation)
|
||||
, Maybe (Entity StudyFeatures)
|
||||
, Maybe (Entity StudyTerms)
|
||||
, Maybe (Entity StudyDegree)
|
||||
, Bool -- isParticipant
|
||||
)
|
||||
|
||||
@ -52,34 +45,25 @@ courseApplicationsIdent :: Text
|
||||
courseApplicationsIdent = "applications"
|
||||
|
||||
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
|
||||
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
|
||||
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
|
||||
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
|
||||
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
||||
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
|
||||
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
where
|
||||
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
|
||||
|
||||
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
|
||||
queryAllocation = to $(sqlLOJproj 4 2)
|
||||
|
||||
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
||||
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)
|
||||
|
||||
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 4 3)
|
||||
|
||||
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
||||
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 4 3)
|
||||
queryAllocation = to $(sqlLOJproj 3 2)
|
||||
|
||||
queryCourseParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
|
||||
queryCourseParticipant = to $(sqlLOJproj 4 4)
|
||||
queryCourseParticipant = to $(sqlLOJproj 3 3)
|
||||
|
||||
queryIsParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
||||
queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 4 4)
|
||||
queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 3 3)
|
||||
|
||||
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
|
||||
resultCourseApplication = _dbrOutput . _1
|
||||
@ -93,17 +77,8 @@ resultHasFiles = _dbrOutput . _3
|
||||
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
|
||||
resultAllocation = _dbrOutput . _4 . _Just
|
||||
|
||||
resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures)
|
||||
resultStudyFeatures = _dbrOutput . _5 . _Just
|
||||
|
||||
resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms)
|
||||
resultStudyTerms = _dbrOutput . _6 . _Just
|
||||
|
||||
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _7 . _Just
|
||||
|
||||
resultIsParticipant :: Lens' CourseApplicationsTableData Bool
|
||||
resultIsParticipant = _dbrOutput . _8
|
||||
resultIsParticipant = _dbrOutput . _5
|
||||
|
||||
|
||||
newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
|
||||
@ -127,9 +102,6 @@ data CourseApplicationsTableCsv = CourseApplicationsTableCsv
|
||||
, csvCAName :: Maybe Text
|
||||
, csvCAEmail :: Maybe UserEmail
|
||||
, csvCAMatriculation :: Maybe Text
|
||||
, csvCAField :: Maybe Text
|
||||
, csvCADegree :: Maybe Text
|
||||
, csvCASemester :: Maybe Int
|
||||
, csvCAText :: Maybe Text
|
||||
, csvCAHasFiles :: Maybe Bool
|
||||
, csvCAVeto :: Maybe CourseApplicationsTableVeto
|
||||
@ -152,9 +124,6 @@ instance Csv.FromNamedRecord CourseApplicationsTableCsv where
|
||||
<*> csv .:?? "name"
|
||||
<*> csv .:?? "email"
|
||||
<*> csv .:?? "matriculation"
|
||||
<*> csv .:?? "field"
|
||||
<*> csv .:?? "degree"
|
||||
<*> csv .:?? "semester"
|
||||
<*> csv .:?? "text"
|
||||
<*> csv .:?? "has-files"
|
||||
<*> csv .:?? "veto"
|
||||
@ -171,9 +140,6 @@ instance CsvColumnsExplained CourseApplicationsTableCsv where
|
||||
, ('csvCAName , MsgCsvColumnApplicationsName )
|
||||
, ('csvCAEmail , MsgCsvColumnApplicationsEmail )
|
||||
, ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation)
|
||||
, ('csvCAField , MsgCsvColumnApplicationsField )
|
||||
, ('csvCADegree , MsgCsvColumnApplicationsDegree )
|
||||
, ('csvCASemester , MsgCsvColumnApplicationsSemester )
|
||||
, ('csvCAText , MsgCsvColumnApplicationsText )
|
||||
, ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles )
|
||||
, ('csvCAVeto , MsgCsvColumnApplicationsVeto )
|
||||
@ -182,19 +148,14 @@ instance CsvColumnsExplained CourseApplicationsTableCsv where
|
||||
]
|
||||
|
||||
data CourseApplicationsTableCsvActionClass
|
||||
= CourseApplicationsTableCsvSetField
|
||||
| CourseApplicationsTableCsvSetVeto
|
||||
= CourseApplicationsTableCsvSetVeto
|
||||
| CourseApplicationsTableCsvSetRating
|
||||
| CourseApplicationsTableCsvSetComment
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id
|
||||
|
||||
data CourseApplicationsTableCsvAction
|
||||
= CourseApplicationsTableCsvSetFieldData
|
||||
{ caCsvActApplication :: CourseApplicationId
|
||||
, caCsvActField :: Maybe StudyFeaturesId
|
||||
}
|
||||
| CourseApplicationsTableCsvSetVetoData
|
||||
= CourseApplicationsTableCsvSetVetoData
|
||||
{ caCsvActApplication :: CourseApplicationId
|
||||
, caCsvActVeto :: Bool
|
||||
}
|
||||
@ -284,18 +245,12 @@ postCApplicationsR tid ssh csh = do
|
||||
hasFiles <- view queryHasFiles
|
||||
user <- view queryUser
|
||||
allocation <- view queryAllocation
|
||||
studyFeatures <- view queryStudyFeatures
|
||||
studyTerms <- view queryStudyTerms
|
||||
studyDegree <- view queryStudyDegree
|
||||
courseParticipant <- view queryCourseParticipant
|
||||
|
||||
lift $ do
|
||||
E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser
|
||||
E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid)
|
||||
E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
|
||||
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
|
||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
|
||||
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
||||
E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||
@ -306,14 +261,11 @@ postCApplicationsR tid ssh csh = do
|
||||
, user
|
||||
, hasFiles
|
||||
, allocation
|
||||
, studyFeatures
|
||||
, studyTerms
|
||||
, studyDegree
|
||||
, E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
|
||||
)
|
||||
|
||||
dbtProj :: DBRow _ -> DB CourseApplicationsTableData
|
||||
dbtProj = traverse $ return . over _3 E.unValue . over _8 E.unValue
|
||||
dbtProj = traverse $ return . over _3 E.unValue . over _5 E.unValue
|
||||
|
||||
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
|
||||
|
||||
@ -325,9 +277,6 @@ postCApplicationsR tid ssh csh = do
|
||||
, anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||
, lmap (view $ resultUser . _entityVal) colUserEmail
|
||||
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||
, emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms
|
||||
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
|
||||
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
|
||||
, colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
|
||||
, lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
|
||||
, colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
|
||||
@ -341,9 +290,6 @@ postCApplicationsR tid ssh csh = do
|
||||
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
|
||||
, uncurry singletonMap . sortUserEmail $ view queryUser
|
||||
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, sortStudyTerms queryStudyTerms
|
||||
, sortStudyDegree queryStudyDegree
|
||||
, sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, sortApplicationFiles queryHasFiles
|
||||
, sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
@ -356,9 +302,6 @@ postCApplicationsR tid ssh csh = do
|
||||
, fltrUserName' $ queryUser . to (E.^. UserDisplayName)
|
||||
, uncurry singletonMap . fltrUserEmail $ view queryUser
|
||||
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, fltrStudyTerms queryStudyTerms
|
||||
, fltrStudyDegree queryStudyDegree
|
||||
, fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, fltrApplicationFiles queryHasFiles
|
||||
, fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
@ -370,9 +313,6 @@ postCApplicationsR tid ssh csh = do
|
||||
, fltrUserNameUI'
|
||||
, fltrUserMatriculationUI
|
||||
, fltrUserEmailUI
|
||||
, fltrStudyTermsUI
|
||||
, fltrStudyDegreeUI
|
||||
, fltrStudyFeaturesSemesterUI
|
||||
, fltrApplicationTextUI
|
||||
, fltrApplicationFilesUI
|
||||
, fltrApplicationVetoUI
|
||||
@ -391,9 +331,6 @@ postCApplicationsR tid ssh csh = do
|
||||
<*> preview (resultUser . _entityVal . _userDisplayName)
|
||||
<*> preview (resultUser . _entityVal . _userEmail)
|
||||
<*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just)
|
||||
<*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey)))
|
||||
<*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey)))
|
||||
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
||||
<*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just)
|
||||
<*> preview resultHasFiles
|
||||
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto)
|
||||
@ -416,10 +353,6 @@ postCApplicationsR tid ssh csh = do
|
||||
DBCsvDiffExisting{..} -> do
|
||||
let appId = dbCsvOld ^. resultCourseApplication . _entityKey
|
||||
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
|
||||
yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures
|
||||
|
||||
let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
|
||||
whenIsJust mVeto $ \veto ->
|
||||
when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
|
||||
@ -431,18 +364,12 @@ postCApplicationsR tid ssh csh = do
|
||||
when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $
|
||||
yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment)
|
||||
, dbtCsvClassifyAction = \case
|
||||
CourseApplicationsTableCsvSetFieldData{} -> CourseApplicationsTableCsvSetField
|
||||
CourseApplicationsTableCsvSetVetoData{} -> CourseApplicationsTableCsvSetVeto
|
||||
CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating
|
||||
CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
|
||||
, dbtCsvCoarsenActionClass = const DBCsvActionExisting
|
||||
, dbtCsvExecuteActions = do
|
||||
C.mapM_ $ \case
|
||||
CourseApplicationsTableCsvSetFieldData{..} -> do
|
||||
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField
|
||||
, CourseApplicationTime =. now
|
||||
]
|
||||
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||
CourseApplicationsTableCsvSetVetoData{..} -> do
|
||||
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto
|
||||
, CourseApplicationRatingTime =. Just now
|
||||
@ -460,15 +387,6 @@ postCApplicationsR tid ssh csh = do
|
||||
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
|
||||
return $ CourseR tid ssh csh CApplicationsR
|
||||
, dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case
|
||||
CourseApplicationsTableCsvSetFieldData{..} ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{existingApplicantName' caCsvActApplication}
|
||||
$maybe features <- caCsvActField
|
||||
, ^{studyFeaturesWidget features}
|
||||
$nothing
|
||||
, _{MsgCourseStudyFeatureNone}
|
||||
|]
|
||||
CourseApplicationsTableCsvSetVetoData{..} ->
|
||||
[whamlet|
|
||||
$newline never
|
||||
@ -538,59 +456,6 @@ postCApplicationsR tid ssh csh = do
|
||||
where
|
||||
Entity _ User{..} = existing ^. singular (ix appId . resultUser)
|
||||
|
||||
lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId)
|
||||
lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do
|
||||
appRes <- guessUser csv
|
||||
(uid, oldFeatures) <- case appRes of
|
||||
Left uid -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] []
|
||||
Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId
|
||||
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
|
||||
E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
|
||||
, E.asc (studyFeatures E.^. StudyFeaturesDegree)
|
||||
, E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
|
||||
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
||||
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
||||
E.where_ . E.and $ catMaybes
|
||||
[ do
|
||||
field <- csvCAField
|
||||
return . E.or $ catMaybes
|
||||
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
|
||||
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
|
||||
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
|
||||
]
|
||||
, do
|
||||
degree <- csvCADegree
|
||||
return . E.or $ catMaybes
|
||||
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
|
||||
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
|
||||
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
|
||||
]
|
||||
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvCASemester
|
||||
]
|
||||
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
||||
let isActiveOrPrevious = E.or
|
||||
$ (studyFeatures E.^. StudyFeaturesValid)
|
||||
: [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId
|
||||
| Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures
|
||||
]
|
||||
E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
|
||||
E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
|
||||
return $ studyFeatures E.^. StudyFeaturesId
|
||||
case studyFeatures of
|
||||
[E.Value fid] -> return $ Just fid
|
||||
_other
|
||||
| is _Nothing csvCAField
|
||||
, is _Nothing csvCADegree
|
||||
, is _Nothing csvCASemester
|
||||
-> return Nothing
|
||||
_other
|
||||
| [Entity _ CourseApplication{..}] <- oldFeatures
|
||||
, Just sfid <- courseApplicationField
|
||||
, E.Value sfid `elem` studyFeatures
|
||||
-> return $ Just sfid
|
||||
_other -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
|
||||
|
||||
|
||||
dbtIdent = courseApplicationsIdent
|
||||
|
||||
psValidator :: PSValidator _ _
|
||||
|
||||
@ -40,7 +40,6 @@ instance IsInvitableJunction CourseParticipant where
|
||||
type InvitationFor CourseParticipant = Course
|
||||
data InvitableJunction CourseParticipant = JunctionParticipant
|
||||
{ jParticipantRegistration :: UTCTime
|
||||
, jParticipantField :: Maybe StudyFeaturesId
|
||||
, jParticipantAllocated :: Maybe AllocationId
|
||||
, jParticipantState :: CourseParticipantState
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
@ -53,8 +52,8 @@ instance IsInvitableJunction CourseParticipant where
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState))
|
||||
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState) -> CourseParticipant{..})
|
||||
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState))
|
||||
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState) -> CourseParticipant{..})
|
||||
|
||||
instance ToJSON (InvitableJunction CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
@ -92,11 +91,9 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
||||
return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
|
||||
return . fmap (, ()) $ JunctionParticipant now <$> pure Nothing <*> pure CourseParticipantActive
|
||||
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
|
||||
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
|
||||
res <- act -- insertUnique
|
||||
@ -109,7 +106,6 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
|
||||
data AddParticipantsResult = AddParticipantsResult
|
||||
{ aurAlreadyRegistered
|
||||
, aurNoUniquePrimaryField
|
||||
, aurSuccess :: Set UserId
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
@ -169,20 +165,14 @@ addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
=> AddParticipantsResult
|
||||
-> ReaderT (YesodPersistBackend UniWorX) m [Message]
|
||||
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
|
||||
(aurAlreadyRegistered', aurNoUniquePrimaryField') <-
|
||||
(,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
|
||||
<*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField)
|
||||
aurAlreadyRegistered' <-
|
||||
fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
|
||||
|
||||
unless (null aurAlreadyRegistered) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
unless (null aurNoUniquePrimaryField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
unless (null aurSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
||||
|
||||
@ -200,18 +190,6 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do
|
||||
whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
|
||||
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
|
||||
|
||||
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
|
||||
applications <- lift . lift $ selectList [ CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
|
||||
|
||||
let courseParticipantField
|
||||
| [f] <- features
|
||||
= Just f
|
||||
| [f'] <- nub $ mapMaybe (courseApplicationField . entityVal) applications
|
||||
, f' `elem` features
|
||||
= Just f'
|
||||
| otherwise
|
||||
= Nothing
|
||||
|
||||
courseParticipantRegistration <- liftIO getCurrentTime
|
||||
void . lift . lift $ upsert
|
||||
CourseParticipant
|
||||
@ -222,7 +200,6 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do
|
||||
, ..
|
||||
}
|
||||
[ CourseParticipantRegistration =. courseParticipantRegistration
|
||||
, CourseParticipantField =. courseParticipantField
|
||||
, CourseParticipantAllocated =. Nothing
|
||||
, CourseParticipantState =. CourseParticipantActive
|
||||
]
|
||||
@ -231,9 +208,7 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do
|
||||
|
||||
void . lift . lift $ setUserSubmissionGroup cid uid mbGrp
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid }
|
||||
Just _ -> mempty { aurSuccess = Set.singleton uid }
|
||||
return $ mempty { aurSuccess = Set.singleton uid }
|
||||
|
||||
|
||||
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
|
||||
@ -41,8 +41,7 @@ instance Button UniWorX ButtonCourseRegister where
|
||||
|
||||
|
||||
data CourseRegisterForm = CourseRegisterForm
|
||||
{ crfStudyFeatures :: Maybe StudyFeaturesId
|
||||
, crfApplicationText :: Maybe Text
|
||||
{ crfApplicationText :: Maybe Text
|
||||
, crfApplicationFiles :: Maybe FileUploads
|
||||
}
|
||||
|
||||
@ -82,17 +81,6 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
| otherwise
|
||||
-> return $ FormSuccess ()
|
||||
|
||||
fieldRes <- if
|
||||
| is _Nothing muid
|
||||
-> return $ FormSuccess Nothing
|
||||
| is _Just muid
|
||||
, isRegistered
|
||||
, Just mFeature <- courseApplicationField . entityVal <$> application
|
||||
<|> courseParticipantField . entityVal <$> registration
|
||||
-> wforced (studyFeaturesFieldFor Nothing True (maybeToList mFeature) muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) mFeature
|
||||
| otherwise
|
||||
-> wreq (studyFeaturesFieldFor Nothing False [] muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
||||
|
||||
appTextRes <- let fs | courseApplicationsRequired
|
||||
, is _Just courseApplicationsInstructions
|
||||
= fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions
|
||||
@ -167,7 +155,6 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
|
||||
return $ CourseRegisterForm
|
||||
<$ secretRes
|
||||
<*> fieldRes
|
||||
<*> appTextRes
|
||||
<*> appFilesRes
|
||||
|
||||
@ -200,7 +187,7 @@ postCRegisterR tid ssh csh = do
|
||||
= void <$> do
|
||||
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
|
||||
appRes <- case appIds of
|
||||
[] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing
|
||||
[] -> insertUnique $ CourseApplication cid uid crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing
|
||||
(prevId:ps) -> do
|
||||
forM_ ps $ \appId -> do
|
||||
deleteApplicationFiles appId
|
||||
@ -208,7 +195,7 @@ postCRegisterR tid ssh csh = do
|
||||
audit $ TransactionCourseApplicationDeleted cid uid appId
|
||||
|
||||
deleteApplicationFiles prevId
|
||||
update prevId [ CourseApplicationField =. crfStudyFeatures, CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ]
|
||||
update prevId [ CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ]
|
||||
|
||||
return $ Just prevId
|
||||
|
||||
@ -222,9 +209,8 @@ postCRegisterR tid ssh csh = do
|
||||
mkRegistration = do
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
entityKey <$> upsert
|
||||
(CourseParticipant cid uid cTime crfStudyFeatures Nothing CourseParticipantActive)
|
||||
(CourseParticipant cid uid cTime Nothing CourseParticipantActive)
|
||||
[ CourseParticipantRegistration =. cTime
|
||||
, CourseParticipantField =. crfStudyFeatures
|
||||
, CourseParticipantAllocated =. Nothing
|
||||
, CourseParticipantState =. CourseParticipantActive
|
||||
]
|
||||
|
||||
@ -100,29 +100,6 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
|
||||
return (studyfeat, studydegree, studyterms)
|
||||
return (registration, studies)
|
||||
|
||||
((regFieldRes, regFieldView), regFieldEnctype) <- lift . runFormPost . identifyForm FIDcRegField $ \csrf ->
|
||||
let currentField :: Maybe (Maybe StudyFeaturesId)
|
||||
currentField = courseParticipantField . entityVal <$> mRegistration
|
||||
in over _2 ((toWidget csrf <>) . fvWidget) <$> mreq (studyFeaturesFieldFor Nothing True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
|
||||
|
||||
let registrationFieldFrag :: Text
|
||||
registrationFieldFrag = "registration-field"
|
||||
regFieldWidget = wrapForm regFieldView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
|
||||
, formEncoding = regFieldEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormAutoSubmit
|
||||
, formAnchor = Just registrationFieldFrag
|
||||
}
|
||||
for_ mRegistration $ \(Entity pId CourseParticipant{}) ->
|
||||
formResult regFieldRes $ \courseParticipantField' -> do
|
||||
lift . runDB $ do
|
||||
update pId [ CourseParticipantField =. courseParticipantField' ]
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
addMessageI Success MsgCourseStudyFeatureUpdated
|
||||
redirect $ currentRoute :#: registrationFieldFrag
|
||||
|
||||
mayRegister <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR
|
||||
let regButton
|
||||
| is _Just mRegistration = BtnCourseDeregister
|
||||
@ -179,16 +156,10 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
|
||||
-> invalidArgs ["User not registered"]
|
||||
(BtnCourseRegister, _) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let field
|
||||
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
|
||||
= Just featId
|
||||
| otherwise
|
||||
= Nothing
|
||||
lift . runDBJobs $ do
|
||||
void $ upsert
|
||||
(CourseParticipant cid uid now field Nothing CourseParticipantActive)
|
||||
(CourseParticipant cid uid now Nothing CourseParticipantActive)
|
||||
[ CourseParticipantRegistration =. now
|
||||
, CourseParticipantField =. field
|
||||
, CourseParticipantAllocated =. Nothing
|
||||
, CourseParticipantState =. CourseParticipantActive
|
||||
]
|
||||
|
||||
@ -4,7 +4,7 @@ module Handler.Course.Users
|
||||
( queryUser
|
||||
, makeCourseUserTable
|
||||
, postCUsersR, getCUsersR
|
||||
, colUserDegreeShort, colUserField, colUserSemester, colUserSex'
|
||||
, colUserSex'
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -39,10 +39,6 @@ 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 StudyFeatures))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
)
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity SubmissionGroup))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionGroupUser))
|
||||
)
|
||||
@ -53,50 +49,38 @@ type UserTableExpr = ( E.SqlExpr (Entity User)
|
||||
-- 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 4 1)
|
||||
queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
|
||||
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
|
||||
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
|
||||
queryUserNote = $(sqlLOJproj 4 2)
|
||||
|
||||
queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)
|
||||
|
||||
queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 4 3)
|
||||
|
||||
queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 4 3)
|
||||
queryUserNote = $(sqlLOJproj 3 2)
|
||||
|
||||
querySubmissionGroup :: UserTableExpr -> E.SqlExpr (Maybe (Entity SubmissionGroup))
|
||||
querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 4 4)
|
||||
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)))
|
||||
, StudyFeaturesDescription'
|
||||
, E.SqlExpr (Maybe (Entity SubmissionGroup))
|
||||
)
|
||||
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures `E.LeftOuterJoin` (subGroup `E.InnerJoin` subGroupUser)) = do
|
||||
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)
|
||||
features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
|
||||
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, features, subGroup)
|
||||
return (user, participant, note E.?. CourseUserNoteId, subGroup)
|
||||
|
||||
|
||||
type UserTableData = DBRow ( Entity User
|
||||
, Entity CourseParticipant
|
||||
, Maybe CourseUserNoteId
|
||||
, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
|
||||
, ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
|
||||
, [Entity Exam]
|
||||
, Maybe (Entity SubmissionGroup)
|
||||
@ -118,23 +102,17 @@ _userTableRegistration = _userTableParticipant . _entityVal . _courseParticipant
|
||||
_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
|
||||
_userTableNote = _dbrOutput . _3
|
||||
|
||||
_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
|
||||
_userTableFeatures = _dbrOutput . _4
|
||||
|
||||
_rowUserSemester :: Traversal' UserTableData Int
|
||||
_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
|
||||
|
||||
_userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
|
||||
_userTutorials = _dbrOutput . _5
|
||||
_userTutorials = _dbrOutput . _4
|
||||
|
||||
_userExams :: Lens' UserTableData [Entity Exam]
|
||||
_userExams = _dbrOutput . _6
|
||||
_userExams = _dbrOutput . _5
|
||||
|
||||
_userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup)
|
||||
_userSubmissionGroup = _dbrOutput . _7 . _Just
|
||||
_userSubmissionGroup = _dbrOutput . _6 . _Just
|
||||
|
||||
_userSheets :: Lens' UserTableData (Map SheetName (SheetType, Maybe Points))
|
||||
_userSheets = _dbrOutput . _8
|
||||
_userSheets = _dbrOutput . _7
|
||||
|
||||
|
||||
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
||||
@ -161,26 +139,6 @@ colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams)
|
||||
(\(Entity _ Exam{..}) -> CExamR tid ssh csh examName EUsersR)
|
||||
(examName . entityVal)
|
||||
|
||||
colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
|
||||
foldMap numCell . preview _rowUserSemester
|
||||
|
||||
colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
|
||||
foldMap i18nCell . view (_userTableFeatures . _3)
|
||||
|
||||
-- colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
-- colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
|
||||
-- foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3)
|
||||
|
||||
-- colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
-- colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
|
||||
-- foldMap i18nCell . preview (_userTableFeatures . _2 . _Just)
|
||||
|
||||
colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
|
||||
foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
|
||||
|
||||
colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
||||
colUserSex' = colUserSex $ hasUser . _userSex
|
||||
|
||||
@ -216,7 +174,7 @@ data UserTableCsv = UserTableCsv
|
||||
, csvUserSex :: Maybe Sex
|
||||
, csvUserMatriculation :: Maybe Text
|
||||
, csvUserEmail :: CI Email
|
||||
, csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature)
|
||||
, csvUserStudyFeatures :: Set UserTableCsvStudyFeature
|
||||
, csvUserSubmissionGroup :: Maybe SubmissionGroupName
|
||||
, csvUserRegistration :: UTCTime
|
||||
, csvUserNote :: Maybe Html
|
||||
@ -232,18 +190,11 @@ instance Csv.ToNamedRecord UserTableCsv where
|
||||
, "sex" Csv..= csvUserSex
|
||||
, "matriculation" Csv..= csvUserMatriculation
|
||||
, "email" Csv..= csvUserEmail
|
||||
] ++ case csvUserStudyFeatures of
|
||||
Left feats
|
||||
-> [ "field" Csv..= (csvUserField <$> feats)
|
||||
, "degree" Csv..= (csvUserDegree <$> feats)
|
||||
, "semester" Csv..= (csvUserSemester <$> feats)
|
||||
]
|
||||
Right feats
|
||||
-> let featsStr = Text.intercalate "; " . flip map (Set.toList feats) $ \UserTableCsvStudyFeature{..}
|
||||
-> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType
|
||||
in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|]
|
||||
in [ "study-features" Csv..= featsStr
|
||||
]
|
||||
] ++ let featsStr = Text.intercalate "; " . flip map (Set.toList csvUserStudyFeatures) $ \UserTableCsvStudyFeature{..}
|
||||
-> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType
|
||||
in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|]
|
||||
in [ "study-features" Csv..= featsStr
|
||||
]
|
||||
++
|
||||
[ "submission-group" Csv..= csvUserSubmissionGroup
|
||||
] ++
|
||||
@ -270,9 +221,6 @@ instance CsvColumnsExplained UserTableCsv where
|
||||
, single "matriculation" MsgCsvColumnUserMatriculation
|
||||
, single "email" MsgCsvColumnUserEmail
|
||||
, single "study-features" MsgCsvColumnUserStudyFeatures
|
||||
, single "field" MsgCsvColumnUserField
|
||||
, single "degree" MsgCsvColumnUserDegree
|
||||
, single "semester" MsgCsvColumnUserSemester
|
||||
, single "submission-group" MsgCsvColumnUserSubmissionGroup
|
||||
, single "tutorial" MsgCsvColumnUserTutorial
|
||||
, single "exams" MsgCsvColumnUserExam
|
||||
@ -284,18 +232,18 @@ instance CsvColumnsExplained UserTableCsv where
|
||||
single k v = singletonMap k [whamlet|_{v}|]
|
||||
|
||||
data UserCsvExportData = UserCsvExportData
|
||||
{ csvUserSimplifiedFeaturesOfStudy :: Bool
|
||||
, csvUserIncludeSheets :: Bool
|
||||
{ csvUserIncludeSheets :: Bool
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance Default UserCsvExportData where
|
||||
def = UserCsvExportData True False
|
||||
def = UserCsvExportData False
|
||||
|
||||
userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExportData -> Csv.Header
|
||||
userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $
|
||||
[ "name" ] ++
|
||||
[ "sex" | showSex ] ++
|
||||
[ "matriculation", "email"
|
||||
] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++
|
||||
] ++
|
||||
["study-features"] ++
|
||||
[ "tutorial" | hasEmptyRegGroup ] ++
|
||||
map (encodeUtf8 . CI.foldedCase) regGroups ++
|
||||
[ "exams", "registration" ] ++
|
||||
@ -376,7 +324,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = traverse $ \(user, participant, E.Value userNoteId, (feature,degree,terms), subGroup) -> do
|
||||
dbtProj = traverse $ \(user, participant, E.Value userNoteId, subGroup) -> do
|
||||
tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
|
||||
exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
|
||||
subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
|
||||
@ -395,7 +343,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
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) exams') exams
|
||||
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, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts, exs, subGroup, subs)
|
||||
return (user, participant, userNoteId, tuts, exs, subGroup, subs)
|
||||
dbtColonnade = colChoices
|
||||
dbtSorting = mconcat
|
||||
[ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header
|
||||
@ -404,11 +352,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
, single $ sortUserEmail queryUser
|
||||
, single $ sortUserMatriclenr queryUser
|
||||
, sortUserSex (to queryUser . to (E.^. UserSex))
|
||||
, single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
|
||||
, single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
|
||||
, single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
||||
, single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
||||
E.subSelectMaybe . E.from $ \edit -> do
|
||||
@ -450,20 +393,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
, single $ fltrUserMatriclenr queryUser
|
||||
, single $ fltrUserNameEmail queryUser
|
||||
, fltrUserSex (to queryUser . to (E.^. UserSex))
|
||||
, single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
|
||||
, single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
|
||||
, single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
|
||||
, single ("field" , FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
|
||||
] )
|
||||
, single ("degree" , FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
||||
] )
|
||||
, single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
@ -497,9 +426,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
, fltrUserMatriclenrUI mPrev
|
||||
] ++
|
||||
[ fltrUserSexUI mPrev | showSex ] ++
|
||||
[ prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
|
||||
, prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature)
|
||||
, prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
|
||||
[ prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
|
||||
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial)
|
||||
, prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam)
|
||||
] ++
|
||||
@ -523,44 +450,28 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
||||
csvColumns' <- csvColumns
|
||||
return $ DBTCsvEncode
|
||||
{ dbtCsvExportForm = UserCsvExportData
|
||||
<$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
|
||||
<*> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def)
|
||||
, dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $
|
||||
<$> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def)
|
||||
, dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $
|
||||
UserTableCsv
|
||||
<$> view (hasUser . _userDisplayName)
|
||||
<*> view (hasUser . _userSex)
|
||||
<*> view (hasUser . _userMatrikelnummer)
|
||||
<*> view (hasUser . _userEmail)
|
||||
<*> if
|
||||
| csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $
|
||||
<*> (do
|
||||
feats <- lift . E.select . E.from $ \(feat `E.InnerJoin` terms `E.InnerJoin` degree) -> do
|
||||
E.on $ degree E.^. StudyDegreeId E.==. feat E.^. StudyFeaturesDegree
|
||||
E.on $ terms E.^. StudyTermsId E.==. feat E.^. StudyFeaturesField
|
||||
E.where_ $ feat E.^. StudyFeaturesValid
|
||||
E.where_ $ feat E.^. StudyFeaturesUser E.==. E.val uid
|
||||
return (terms, degree, feat)
|
||||
return . Set.fromList . flip map feats $ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) ->
|
||||
UserTableCsvStudyFeature
|
||||
<$> MaybeT (preview $ _userTableFeatures . _3 . _Just . _studyTermsName . _Just
|
||||
<> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow
|
||||
)
|
||||
<*> MaybeT (preview $ _userTableFeatures . _2 . _Just . _studyDegreeName . _Just
|
||||
<> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow
|
||||
)
|
||||
<*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesSemester)
|
||||
<*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesType)
|
||||
| otherwise -> Right <$> do
|
||||
feats <- lift . E.select . E.from $ \(feat `E.InnerJoin` terms `E.InnerJoin` degree) -> do
|
||||
E.on $ degree E.^. StudyDegreeId E.==. feat E.^. StudyFeaturesDegree
|
||||
E.on $ terms E.^. StudyTermsId E.==. feat E.^. StudyFeaturesField
|
||||
let registered = E.exists . E.from $ \participant ->
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
||||
E.&&. participant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.&&. participant E.^. CourseParticipantField E.==. E.just (feat E.^. StudyFeaturesId)
|
||||
E.where_ $ registered
|
||||
E.||. feat E.^. StudyFeaturesValid
|
||||
E.where_ $ feat E.^. StudyFeaturesUser E.==. E.val uid
|
||||
return (terms, degree, feat)
|
||||
return . Set.fromList . flip map feats $ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) ->
|
||||
UserTableCsvStudyFeature
|
||||
{ csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName
|
||||
, csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
|
||||
, csvUserSemester = studyFeaturesSemester
|
||||
, csvUserType = studyFeaturesType
|
||||
}
|
||||
{ csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName
|
||||
, csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
|
||||
, csvUserSemester = studyFeaturesSemester
|
||||
, csvUserType = studyFeaturesType
|
||||
}
|
||||
)
|
||||
<*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
|
||||
<*> view _userTableRegistration
|
||||
<*> userNote
|
||||
@ -636,9 +547,6 @@ postCUsersR tid ssh csh = do
|
||||
, guardOn showSex . cap' $ colUserSex'
|
||||
, pure . cap' $ colUserEmail
|
||||
, pure . cap' $ colUserMatriclenr
|
||||
, pure . cap' $ colUserDegreeShort
|
||||
, pure . cap' $ colUserField
|
||||
, pure . cap' $ colUserSemester
|
||||
, guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
|
||||
, guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
|
||||
, guardOn hasExams . cap' $ colUserExams tid ssh csh
|
||||
|
||||
@ -154,7 +154,6 @@ postEAddUserR tid ssh csh examn = do
|
||||
}
|
||||
[ CourseParticipantRegistration =. now
|
||||
, CourseParticipantAllocated =. Nothing
|
||||
, CourseParticipantField =. courseParticipantField
|
||||
, CourseParticipantState =. CourseParticipantActive
|
||||
]
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
|
||||
@ -95,16 +95,13 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
|
||||
case (isRegistered, invDBExamRegistrationCourseRegister) of
|
||||
(False, False) -> permissionDeniedI MsgUnauthorizedParticipant
|
||||
(False, True ) -> do
|
||||
fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
|
||||
return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
|
||||
whenIsJust mField $ \cpField -> do
|
||||
(False, True ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, True)
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, False)
|
||||
invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} doReg act = do
|
||||
when doReg $ do
|
||||
void $ upsert
|
||||
(CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing CourseParticipantActive)
|
||||
(CourseParticipant examCourse examRegistrationUser examRegistrationTime Nothing CourseParticipantActive)
|
||||
[ CourseParticipantRegistration =. examRegistrationTime
|
||||
, CourseParticipantField =. cpField
|
||||
, CourseParticipantAllocated =. Nothing
|
||||
, CourseParticipantState =. CourseParticipantActive
|
||||
]
|
||||
|
||||
@ -47,21 +47,13 @@ type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant))
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamBonus))
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
|
||||
type ExamUserTableData = DBRow ( Entity ExamRegistration
|
||||
, Entity User
|
||||
, Maybe (Entity ExamOccurrence)
|
||||
, Maybe (Entity StudyFeatures)
|
||||
, Maybe (Entity StudyDegree)
|
||||
, Maybe (Entity StudyTerms)
|
||||
, Maybe (Entity ExamBonus)
|
||||
, Maybe (Entity ExamResult)
|
||||
, Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))
|
||||
@ -87,16 +79,7 @@ queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurre
|
||||
queryExamOccurrence = $(sqlLOJproj 6 2)
|
||||
|
||||
queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant))
|
||||
queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3)
|
||||
|
||||
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
|
||||
|
||||
queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
|
||||
|
||||
queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
|
||||
queryCourseParticipant = $(sqlLOJproj 6 3)
|
||||
|
||||
queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus))
|
||||
queryExamBonus = $(sqlLOJproj 6 4)
|
||||
@ -130,38 +113,29 @@ resultExamRegistration = _dbrOutput . _1
|
||||
resultUser :: Lens' ExamUserTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
|
||||
resultStudyFeatures = _dbrOutput . _4 . _Just
|
||||
|
||||
resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _5 . _Just
|
||||
|
||||
resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
|
||||
resultStudyField = _dbrOutput . _6 . _Just
|
||||
|
||||
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
|
||||
resultExamOccurrence = _dbrOutput . _3 . _Just
|
||||
|
||||
resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus)
|
||||
resultExamBonus = _dbrOutput . _7 . _Just
|
||||
resultExamBonus = _dbrOutput . _4 . _Just
|
||||
|
||||
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
|
||||
resultExamResult = _dbrOutput . _8 . _Just
|
||||
resultExamResult = _dbrOutput . _5 . _Just
|
||||
|
||||
resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult))
|
||||
resultExamParts = _dbrOutput . _9 . itraversed
|
||||
resultExamParts = _dbrOutput . _6 . itraversed
|
||||
|
||||
-- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart)
|
||||
-- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity
|
||||
|
||||
resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult))
|
||||
resultExamPartResult epId = _dbrOutput . _9 . unsafeSingular (ix epId) . _2
|
||||
resultExamPartResult epId = _dbrOutput . _6 . unsafeSingular (ix epId) . _2
|
||||
|
||||
resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
|
||||
resultExamPartResults = resultExamParts <. _2
|
||||
|
||||
resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
|
||||
resultCourseNote = _dbrOutput . _10 . _Just
|
||||
resultCourseNote = _dbrOutput . _7 . _Just
|
||||
|
||||
|
||||
resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
|
||||
@ -191,9 +165,6 @@ data ExamUserTableCsv = ExamUserTableCsv
|
||||
, csvEUserFirstName :: Maybe Text
|
||||
, csvEUserName :: Maybe Text
|
||||
, csvEUserMatriculation :: Maybe Text
|
||||
, csvEUserField :: Maybe Text
|
||||
, csvEUserDegree :: Maybe Text
|
||||
, csvEUserSemester :: Maybe Int
|
||||
, csvEUserOccurrence :: Maybe (CI Text)
|
||||
, csvEUserExercisePoints :: Maybe (Maybe Points)
|
||||
, csvEUserExerciseNumPasses :: Maybe (Maybe Int)
|
||||
@ -213,9 +184,6 @@ instance ToNamedRecord ExamUserTableCsv where
|
||||
, "first-name" Csv..= csvEUserFirstName
|
||||
, "name" Csv..= csvEUserName
|
||||
, "matriculation" Csv..= csvEUserMatriculation
|
||||
, "field" Csv..= csvEUserField
|
||||
, "degree" Csv..= csvEUserDegree
|
||||
, "semester" Csv..= csvEUserSemester
|
||||
, "occurrence" Csv..= csvEUserOccurrence
|
||||
] ++ catMaybes
|
||||
[ fmap ("exercise-points" Csv..=) csvEUserExercisePoints
|
||||
@ -240,9 +208,6 @@ instance FromNamedRecord ExamUserTableCsv where
|
||||
<*> csv .:?? "first-name"
|
||||
<*> csv .:?? "name"
|
||||
<*> csv .:?? "matriculation"
|
||||
<*> csv .:?? "field"
|
||||
<*> csv .:?? "degree"
|
||||
<*> csv .:?? "semester"
|
||||
<*> csv .:?? "occurrence"
|
||||
<*> fmap Just (csv .:?? "exercise-points")
|
||||
<*> fmap Just (csv .:?? "exercise-num-passes")
|
||||
@ -263,9 +228,6 @@ instance CsvColumnsExplained ExamUserTableCsv where
|
||||
, single "first-name" MsgCsvColumnExamUserFirstName
|
||||
, single "name" MsgCsvColumnExamUserName
|
||||
, single "matriculation" MsgCsvColumnExamUserMatriculation
|
||||
, single "field" MsgCsvColumnExamUserField
|
||||
, single "degree" MsgCsvColumnExamUserDegree
|
||||
, single "semester" MsgCsvColumnExamUserSemester
|
||||
, single "occurrence" MsgCsvColumnExamUserOccurrence
|
||||
, single "exercise-points" MsgCsvColumnExamUserExercisePoints
|
||||
, single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses
|
||||
@ -287,7 +249,6 @@ examUserTableCsvHeader :: ( MonoFoldable mono
|
||||
examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
|
||||
[ "surname", "first-name", "name"
|
||||
, "matriculation"
|
||||
, "field", "degree", "semester"
|
||||
, "course-note"
|
||||
, "occurrence"
|
||||
] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints)
|
||||
@ -329,7 +290,6 @@ data ExamUserCsvActionClass
|
||||
= ExamUserCsvCourseRegister
|
||||
| ExamUserCsvRegister
|
||||
| ExamUserCsvAssignOccurrence
|
||||
| ExamUserCsvSetCourseField
|
||||
| ExamUserCsvSetPartResult
|
||||
| ExamUserCsvSetBonus
|
||||
| ExamUserCsvOverrideBonus
|
||||
@ -343,7 +303,6 @@ embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
|
||||
data ExamUserCsvAction
|
||||
= ExamUserCsvCourseRegisterData
|
||||
{ examUserCsvActUser :: UserId
|
||||
, examUserCsvActCourseField :: Maybe StudyFeaturesId
|
||||
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
||||
}
|
||||
| ExamUserCsvRegisterData
|
||||
@ -354,10 +313,6 @@ data ExamUserCsvAction
|
||||
{ examUserCsvActRegistration :: ExamRegistrationId
|
||||
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
||||
}
|
||||
| ExamUserCsvSetCourseFieldData
|
||||
{ examUserCsvActCourseParticipant :: CourseParticipantId
|
||||
, examUserCsvActCourseField :: Maybe StudyFeaturesId
|
||||
}
|
||||
| ExamUserCsvDeregisterData
|
||||
{ examUserCsvActRegistration :: ExamRegistrationId
|
||||
}
|
||||
@ -453,9 +408,6 @@ postEUsersR tid ssh csh examn = do
|
||||
user <- asks queryUser
|
||||
occurrence <- asks queryExamOccurrence
|
||||
courseParticipant <- asks queryCourseParticipant
|
||||
studyFeatures <- asks queryStudyFeatures
|
||||
studyDegree <- asks queryStudyDegree
|
||||
studyField <- asks queryStudyField
|
||||
examBonus' <- asks queryExamBonus
|
||||
examResult <- asks queryExamResult
|
||||
courseUserNote <- asks queryCourseNote
|
||||
@ -467,9 +419,6 @@ postEUsersR tid ssh csh examn = do
|
||||
E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
|
||||
E.on $ examBonus' E.?. ExamBonusUser E.==. E.just (user E.^. UserId)
|
||||
E.&&. examBonus' E.?. ExamBonusExam E.==. E.just (E.val eid)
|
||||
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
|
||||
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
|
||||
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
|
||||
E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
|
||||
@ -479,13 +428,13 @@ postEUsersR tid ssh csh examn = do
|
||||
|
||||
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
|
||||
|
||||
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote)
|
||||
return (examRegistration, user, occurrence, examBonus', examResult, courseUserNote)
|
||||
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
|
||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
|
||||
(,,,,,,,,,)
|
||||
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view _8
|
||||
(,,,,,,)
|
||||
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5
|
||||
<*> getExamParts
|
||||
<*> view _9
|
||||
<*> view _6
|
||||
where
|
||||
getExamParts :: ReaderT _ DB (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
|
||||
getExamParts = do
|
||||
@ -504,9 +453,6 @@ postEUsersR tid ssh csh examn = do
|
||||
[ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
|
||||
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
|
||||
, pure colUserMatriclenr
|
||||
, pure $ colField resultStudyField
|
||||
, pure $ colDegreeShort resultStudyDegree
|
||||
, pure $ colFeaturesSemester resultStudyFeatures
|
||||
, pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
|
||||
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
|
||||
let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus
|
||||
@ -528,9 +474,6 @@ postEUsersR tid ssh csh examn = do
|
||||
dbtSorting = mconcat
|
||||
[ uncurry singletonMap $ sortUserNameLink queryUser
|
||||
, uncurry singletonMap $ sortUserMatriclenr queryUser
|
||||
, uncurry singletonMap $ sortField queryStudyField
|
||||
, uncurry singletonMap $ sortDegreeShort queryStudyDegree
|
||||
, uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures
|
||||
, mconcat
|
||||
[ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult
|
||||
| Entity epId ExamPart{..} <- examParts
|
||||
@ -546,18 +489,12 @@ postEUsersR tid ssh csh examn = do
|
||||
dbtFilter = mconcat
|
||||
[ uncurry singletonMap $ fltrUserNameEmail queryUser
|
||||
, uncurry singletonMap $ fltrUserMatriclenr queryUser
|
||||
, uncurry singletonMap $ fltrField queryStudyField
|
||||
, uncurry singletonMap $ fltrDegree queryStudyDegree
|
||||
, uncurry singletonMap $ fltrFeaturesSemester queryStudyFeatures
|
||||
, uncurry singletonMap ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
||||
, fltrExamResultPoints (to $ queryExamResult >>> (E.?. ExamResultResult))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat $ catMaybes
|
||||
[ Just $ fltrUserNameEmailUI mPrev
|
||||
, Just $ fltrUserMatriclenrUI mPrev
|
||||
, Just $ fltrFieldUI mPrev
|
||||
, Just $ fltrDegreeUI mPrev
|
||||
, Just $ fltrFeaturesSemesterUI mPrev
|
||||
, Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) $ optionsF [CI.original examOccurrenceName | Entity _ ExamOccurrence{..} <- occurrences]) (fslI MsgExamOccurrence)
|
||||
, Just $ fltrExamResultPointsUI mPrev
|
||||
]
|
||||
@ -627,9 +564,6 @@ postEUsersR tid ssh csh examn = do
|
||||
<*> view (resultUser . _entityVal . _userFirstName . to Just)
|
||||
<*> view (resultUser . _entityVal . _userDisplayName . to Just)
|
||||
<*> view (resultUser . _entityVal . _userMatrikelnummer)
|
||||
<*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
|
||||
<*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
|
||||
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
||||
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
|
||||
<*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped)
|
||||
<*> fmap (bool (const Nothing) Just showPasses) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral)
|
||||
@ -650,15 +584,8 @@ postEUsersR tid ssh csh examn = do
|
||||
-> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
|
||||
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
|
||||
(isPart, uid) <- lift $ guessUser' dbCsvNew
|
||||
if
|
||||
| isPart -> do
|
||||
yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
|
||||
when (newFeatures /= oldFeatures) $
|
||||
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
|
||||
| otherwise ->
|
||||
yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
|
||||
unless isPart $
|
||||
yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupOccurrence dbCsvNew
|
||||
|
||||
iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
|
||||
when (epNumber `elem` examPartNumbers) $
|
||||
@ -679,11 +606,6 @@ postEUsersR tid ssh csh examn = do
|
||||
when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $
|
||||
yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence
|
||||
|
||||
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
||||
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
|
||||
Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
|
||||
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
|
||||
|
||||
let uid = dbCsvOld ^. resultUser . _entityKey
|
||||
|
||||
forM_ examPartNumbers $ \epNumber ->
|
||||
@ -742,7 +664,6 @@ postEUsersR tid ssh csh examn = do
|
||||
ExamUserCsvRegisterData{} -> ExamUserCsvRegister
|
||||
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
|
||||
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
|
||||
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
|
||||
ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult
|
||||
ExamUserCsvSetBonusData{..}
|
||||
| examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus
|
||||
@ -765,12 +686,10 @@ postEUsersR tid ssh csh examn = do
|
||||
{ courseParticipantCourse = examCourse
|
||||
, courseParticipantUser = examUserCsvActUser
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantField = examUserCsvActCourseField
|
||||
, courseParticipantAllocated = Nothing
|
||||
, courseParticipantState = CourseParticipantActive
|
||||
}
|
||||
[ CourseParticipantRegistration =. now
|
||||
, CourseParticipantField =. examUserCsvActCourseField
|
||||
, CourseParticipantAllocated =. Nothing
|
||||
, CourseParticipantState =. CourseParticipantActive
|
||||
]
|
||||
@ -794,10 +713,6 @@ postEUsersR tid ssh csh examn = do
|
||||
audit $ TransactionExamRegister eid examUserCsvActUser
|
||||
ExamUserCsvAssignOccurrenceData{..} ->
|
||||
update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
|
||||
ExamUserCsvSetCourseFieldData{..} -> do
|
||||
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
|
||||
CourseParticipant{..} <- getJust examUserCsvActCourseParticipant
|
||||
audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser
|
||||
ExamUserCsvSetPartResultData{..} -> do
|
||||
epid <- getKeyJustBy $ UniqueExamPartNumber eid examUserCsvActExamPart
|
||||
case examUserCsvActExamPartResult of
|
||||
@ -864,10 +779,6 @@ postEUsersR tid ssh csh examn = do
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe features <- examUserCsvActCourseField
|
||||
, ^{studyFeaturesWidget features}
|
||||
$nothing
|
||||
, _{MsgCourseStudyFeatureNone}
|
||||
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
||||
\ (#{examOccurrenceName})
|
||||
$nothing
|
||||
@ -893,16 +804,6 @@ postEUsersR tid ssh csh examn = do
|
||||
$nothing
|
||||
\ (_{MsgExamNoOccurrence})
|
||||
|]
|
||||
ExamUserCsvSetCourseFieldData{..} -> do
|
||||
User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
|
||||
[whamlet|
|
||||
$newline never
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
$maybe features <- examUserCsvActCourseField
|
||||
, ^{studyFeaturesWidget features}
|
||||
$nothing
|
||||
, _{MsgCourseStudyFeatureNone}
|
||||
|]
|
||||
ExamUserCsvSetPartResultData{..} -> do
|
||||
(User{..}, Entity _ ExamPart{..}) <- liftHandler . runDB $
|
||||
(,) <$> getJust examUserCsvActUser
|
||||
@ -990,56 +891,6 @@ postEUsersR tid ssh csh examn = do
|
||||
[occId] -> return occId
|
||||
_other -> throwM ExamUserCsvExceptionNoMatchingOccurrence
|
||||
|
||||
lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
|
||||
lookupStudyFeatures csv@ExamUserTableCsv{..} = do
|
||||
uid <- view _2 <$> guessUser' csv
|
||||
oldFeatures <- getBy $ UniqueParticipant uid examCourse
|
||||
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
|
||||
E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
|
||||
, E.asc (studyFeatures E.^. StudyFeaturesDegree)
|
||||
, E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
|
||||
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
|
||||
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
|
||||
E.where_ . E.and $ catMaybes
|
||||
[ do
|
||||
field <- csvEUserField
|
||||
return . E.or $ catMaybes
|
||||
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
|
||||
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
|
||||
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
|
||||
]
|
||||
, do
|
||||
degree <- csvEUserDegree
|
||||
return . E.or $ catMaybes
|
||||
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
|
||||
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
|
||||
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
|
||||
]
|
||||
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
|
||||
]
|
||||
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
|
||||
let isActive = studyFeatures E.^. StudyFeaturesValid E.==. E.val True
|
||||
isActiveOrPrevious = case oldFeatures of
|
||||
Just (Entity _ CourseParticipant{courseParticipantField = Just sfid})
|
||||
-> isActive E.||. (E.val sfid E.==. studyFeatures E.^. StudyFeaturesId)
|
||||
_ -> isActive
|
||||
E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
|
||||
E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
|
||||
return $ studyFeatures E.^. StudyFeaturesId
|
||||
case studyFeatures of
|
||||
[E.Value fid] -> return $ Just fid
|
||||
_other
|
||||
| is _Nothing csvEUserField
|
||||
, is _Nothing csvEUserDegree
|
||||
, is _Nothing csvEUserSemester
|
||||
-> return Nothing
|
||||
_other
|
||||
| Just (Entity _ CourseParticipant{..}) <- oldFeatures
|
||||
, Just sfid <- courseParticipantField
|
||||
, E.Value sfid `elem` studyFeatures
|
||||
-> return $ Just sfid
|
||||
_other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
|
||||
|
||||
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
|
||||
& defaultPagesize PagesizeAll
|
||||
|
||||
|
||||
@ -68,18 +68,10 @@ type ExamUserTableExpr = ( E.SqlExpr (Entity ExamResult)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamRegistration))
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant))
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
|
||||
type ExamUserTableData = DBRow ( Entity ExamResult
|
||||
, Entity User
|
||||
, Maybe (Entity ExamOccurrence)
|
||||
, Maybe (Entity StudyFeatures)
|
||||
, Maybe (Entity StudyDegree)
|
||||
, Maybe (Entity StudyTerms)
|
||||
, Maybe (Entity ExamRegistration)
|
||||
, Bool
|
||||
, [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
|
||||
@ -95,16 +87,7 @@ queryExamOccurrence :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamOc
|
||||
queryExamOccurrence = to $(E.sqlLOJproj 4 3)
|
||||
|
||||
queryCourseParticipant :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
|
||||
queryCourseParticipant = to $ $(E.sqlLOJproj 2 1) . $(E.sqlLOJproj 4 4)
|
||||
|
||||
queryStudyFeatures :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
||||
queryStudyFeatures = to $ $(E.sqlIJproj 3 1) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
|
||||
|
||||
queryStudyDegree :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
||||
queryStudyDegree = to $ $(E.sqlIJproj 3 2) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
|
||||
|
||||
queryStudyField :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||
queryStudyField = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
|
||||
queryCourseParticipant = to $(E.sqlLOJproj 4 4)
|
||||
|
||||
queryExamResult :: Getter ExamUserTableExpr (E.SqlExpr (Entity ExamResult))
|
||||
queryExamResult = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1)
|
||||
@ -118,15 +101,6 @@ queryIsSynced authId = to $ Exam.resultIsSynced authId <$> view queryExamResult
|
||||
resultUser :: Lens' ExamUserTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
|
||||
resultStudyFeatures = _dbrOutput . _4 . _Just
|
||||
|
||||
resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _5 . _Just
|
||||
|
||||
resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
|
||||
resultStudyField = _dbrOutput . _6 . _Just
|
||||
|
||||
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
|
||||
resultExamOccurrence = _dbrOutput . _3 . _Just
|
||||
|
||||
@ -134,19 +108,16 @@ resultExamResult :: Lens' ExamUserTableData (Entity ExamResult)
|
||||
resultExamResult = _dbrOutput . _1
|
||||
|
||||
resultIsSynced :: Lens' ExamUserTableData Bool
|
||||
resultIsSynced = _dbrOutput . _8
|
||||
resultIsSynced = _dbrOutput . _5
|
||||
|
||||
resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)
|
||||
resultSynchronised = _dbrOutput . _9 . traverse
|
||||
resultSynchronised = _dbrOutput . _6 . traverse
|
||||
|
||||
data ExamUserTableCsv = ExamUserTableCsv
|
||||
{ csvEUserSurname :: Text
|
||||
, csvEUserFirstName :: Text
|
||||
, csvEUserName :: Text
|
||||
, csvEUserMatriculation :: Maybe Text
|
||||
, csvEUserField :: Maybe Text
|
||||
, csvEUserDegree :: Maybe Text
|
||||
, csvEUserSemester :: Maybe Int
|
||||
, csvEUserOccurrenceStart :: Maybe ZonedTime
|
||||
, csvEUserExamResult :: ExamResultPassedGrade
|
||||
}
|
||||
@ -168,9 +139,6 @@ instance CsvColumnsExplained ExamUserTableCsv where
|
||||
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
|
||||
, ('csvEUserName , MsgCsvColumnExamUserName )
|
||||
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
|
||||
, ('csvEUserField , MsgCsvColumnExamUserField )
|
||||
, ('csvEUserDegree , MsgCsvColumnExamUserDegree )
|
||||
, ('csvEUserSemester , MsgCsvColumnExamUserSemester )
|
||||
, ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart )
|
||||
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
|
||||
]
|
||||
@ -249,16 +217,10 @@ postEGradesR tid ssh csh examn = do
|
||||
examRegistration <- view queryExamRegistration
|
||||
occurrence <- view queryExamOccurrence
|
||||
courseParticipant <- view queryCourseParticipant
|
||||
studyFeatures <- view queryStudyFeatures
|
||||
studyDegree <- view queryStudyDegree
|
||||
studyField <- view queryStudyField
|
||||
|
||||
isSynced <- view . queryIsSynced $ E.val uid
|
||||
|
||||
lift $ do
|
||||
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
|
||||
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
|
||||
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
|
||||
E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
|
||||
@ -274,13 +236,13 @@ postEGradesR tid ssh csh examn = do
|
||||
unless isLecturer $
|
||||
E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult
|
||||
|
||||
return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
|
||||
return (examResult, user, occurrence, examRegistration, isSynced)
|
||||
dbtRowKey = views queryExamResult (E.^. ExamResultId)
|
||||
|
||||
dbtProj :: DBRow _ -> DB ExamUserTableData
|
||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
|
||||
(,,,,,,,,)
|
||||
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view (_8 . _Value)
|
||||
(,,,,,)
|
||||
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value)
|
||||
<*> getSynchronised
|
||||
where
|
||||
getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
|
||||
@ -335,9 +297,6 @@ postEGradesR tid ssh csh examn = do
|
||||
, colSynced
|
||||
, imapColonnade participantAnchor . anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||
, emptyOpticColonnade (resultStudyField . _entityVal) colStudyTerms
|
||||
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
|
||||
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
|
||||
, Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do
|
||||
start <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just
|
||||
end <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceEnd . _Just <> like examEnd . _Just
|
||||
@ -347,9 +306,6 @@ postEGradesR tid ssh csh examn = do
|
||||
dbtSorting = mconcat
|
||||
[ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
|
||||
, sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
||||
, sortStudyTerms queryStudyField
|
||||
, sortStudyDegree queryStudyDegree
|
||||
, sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
|
||||
, sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart)))
|
||||
, maybeOpticSortColumn sortExamResult (queryExamResult . to (E.^. ExamResultResult))
|
||||
, singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
|
||||
@ -357,18 +313,12 @@ postEGradesR tid ssh csh examn = do
|
||||
dbtFilter = mconcat
|
||||
[ fltrUserName' (queryUser . to (E.^. UserDisplayName))
|
||||
, fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
||||
, fltrStudyTerms queryStudyField
|
||||
, fltrStudyDegree queryStudyDegree
|
||||
, fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
|
||||
, fltrExamResultPoints (queryExamResult . to (E.^. ExamResultResult) . to E.just)
|
||||
, singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ fltrUserNameUI'
|
||||
, fltrUserMatriculationUI
|
||||
, fltrStudyTermsUI
|
||||
, fltrStudyDegreeUI
|
||||
, fltrStudyFeaturesSemesterUI
|
||||
, fltrExamResultPointsUI
|
||||
, \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
|
||||
]
|
||||
@ -405,9 +355,6 @@ postEGradesR tid ssh csh examn = do
|
||||
(row ^. resultUser . _entityVal . _userFirstName)
|
||||
(row ^. resultUser . _entityVal . _userDisplayName)
|
||||
(row ^. resultUser . _entityVal . _userMatrikelnummer)
|
||||
(row ^? resultStudyField . _entityVal . to (\StudyTerms{..} -> fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand))
|
||||
(row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand))
|
||||
(row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
||||
(row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime)
|
||||
(row ^. resultExamResult . _entityVal . _examResultResult)
|
||||
, dbtCsvName = unpack csvName
|
||||
|
||||
@ -41,9 +41,6 @@ postTUsersR tid ssh csh tutn = do
|
||||
, guardOn showSex colUserSex'
|
||||
, pure colUserEmail
|
||||
, pure colUserMatriclenr
|
||||
, pure colUserDegreeShort
|
||||
, pure colUserField
|
||||
, pure colUserSemester
|
||||
]
|
||||
psValidator = def
|
||||
& defaultSortingByName
|
||||
@ -51,7 +48,7 @@ postTUsersR tid ssh csh tutn = do
|
||||
isInTut q = E.exists . E.from $ \tutorialParticipant ->
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
csvColChoices = flip elem ["name", "matriculation", "email", "field", "degree", "semester", "study-features"]
|
||||
csvColChoices = flip elem ["name", "matriculation", "email", "study-features"]
|
||||
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator (Just csvColChoices)
|
||||
|
||||
@ -244,11 +244,9 @@ doAllocation :: AllocationId
|
||||
-> DB ()
|
||||
doAllocation allocId now regs =
|
||||
forM_ regs $ \(uid, cid) -> do
|
||||
mField <- (courseApplicationField . entityVal <=< listToMaybe) <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
||||
void $ upsert
|
||||
(CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive)
|
||||
(CourseParticipant cid uid now (Just allocId) CourseParticipantActive)
|
||||
[ CourseParticipantRegistration =. now
|
||||
, CourseParticipantField =. mField
|
||||
, CourseParticipantAllocated =. Just allocId
|
||||
, CourseParticipantState =. CourseParticipantActive
|
||||
]
|
||||
|
||||
@ -56,6 +56,3 @@ $newline never
|
||||
^{formatTimeRangeW SelFormatDate fObs $ Just studyFeaturesLastObserved}
|
||||
$nothing
|
||||
^{formatTimeW SelFormatDate studyFeaturesLastObserved}
|
||||
$maybe _ <- mRegistration
|
||||
<dt .deflist__dt>_{MsgCourseStudyFeature}
|
||||
<dd .deflist__dd>^{regFieldWidget}
|
||||
|
||||
@ -473,58 +473,64 @@ fillDb = do
|
||||
void . insert $ StudyTermNameCandidate incidence12 21 "Deutsch"
|
||||
void . insert $ StudyTermNameCandidate incidence12 21 "Betriebswirtschaftslehre"
|
||||
|
||||
sfMMp <- insert $ StudyFeatures -- keyword type prevents record syntax here
|
||||
insert_ $ StudyFeatures -- keyword type prevents record syntax here
|
||||
maxMuster
|
||||
sdBsc
|
||||
sdInf
|
||||
Nothing
|
||||
FieldPrimary
|
||||
2
|
||||
(Just now)
|
||||
now
|
||||
True
|
||||
sfMMs <- insert $ StudyFeatures
|
||||
insert_ $ StudyFeatures
|
||||
maxMuster
|
||||
sdBsc
|
||||
sdMath
|
||||
Nothing
|
||||
FieldSecondary
|
||||
2
|
||||
(Just now)
|
||||
now
|
||||
True
|
||||
_sfTTa <- insert $ StudyFeatures
|
||||
insert_ $ StudyFeatures
|
||||
tinaTester
|
||||
sdBsc
|
||||
sdInf
|
||||
Nothing
|
||||
FieldPrimary
|
||||
4
|
||||
(Just now)
|
||||
now
|
||||
False
|
||||
sfTTb <- insert $ StudyFeatures
|
||||
insert_ $ StudyFeatures
|
||||
tinaTester
|
||||
sdLAG
|
||||
sdPhys
|
||||
Nothing
|
||||
FieldPrimary
|
||||
1
|
||||
(Just now)
|
||||
now
|
||||
True
|
||||
sfTTc <- insert $ StudyFeatures
|
||||
insert_ $ StudyFeatures
|
||||
tinaTester
|
||||
sdLAR
|
||||
sdMedi
|
||||
Nothing
|
||||
FieldPrimary
|
||||
7
|
||||
(Just now)
|
||||
now
|
||||
True
|
||||
_sfTTd <- insert $ StudyFeatures
|
||||
insert_ $ StudyFeatures
|
||||
tinaTester
|
||||
sdMst
|
||||
sdMath
|
||||
Nothing
|
||||
FieldPrimary
|
||||
3
|
||||
(Just now)
|
||||
now
|
||||
True
|
||||
|
||||
@ -626,10 +632,10 @@ fillDb = do
|
||||
, sheetAllowNonPersonalisedSubmission = True
|
||||
}
|
||||
insert_ $ SheetEdit gkleen now keine
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing CourseParticipantActive)
|
||||
[(fhamann , Nothing)
|
||||
,(maxMuster , Just sfMMs)
|
||||
,(tinaTester, Just sfTTc)
|
||||
void . insertMany $ map (\u -> CourseParticipant ffp u now Nothing CourseParticipantActive)
|
||||
[ fhamann
|
||||
, maxMuster
|
||||
, tinaTester
|
||||
]
|
||||
|
||||
examFFP <- insert' $ Exam
|
||||
@ -762,10 +768,10 @@ fillDb = do
|
||||
insert_ $ CourseEdit jost now pmo
|
||||
void . insert $ DegreeCourse pmo sdBsc sdInf
|
||||
void . insert $ Lecturer jost pmo CourseAssistant
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing CourseParticipantActive)
|
||||
[(fhamann , Nothing)
|
||||
,(maxMuster , Just sfMMp)
|
||||
,(tinaTester, Just sfTTb)
|
||||
void . insertMany $ map (\u -> CourseParticipant pmo u now Nothing CourseParticipantActive)
|
||||
[ fhamann
|
||||
, maxMuster
|
||||
, tinaTester
|
||||
]
|
||||
|
||||
let shTypes = NotGraded : [ shType g | g <- shGradings, shType <- [ Normal, Bonus, Informational ] ]
|
||||
@ -1032,7 +1038,7 @@ fillDb = do
|
||||
insert_ $ AllocationCourse funAlloc pmo 100
|
||||
insert_ $ AllocationCourse funAlloc ffp 2
|
||||
|
||||
void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now Nothing (Just funAlloc) pState)
|
||||
void . insertMany $ map (\(u, pState) -> CourseParticipant ffp u now (Just funAlloc) pState)
|
||||
[ (svaupel, CourseParticipantInactive False)
|
||||
, (jost, CourseParticipantActive)
|
||||
]
|
||||
@ -1066,7 +1072,7 @@ fillDb = do
|
||||
void . insert' $ Lecturer gkleen bs CourseLecturer
|
||||
void . insertMany $ do
|
||||
uid <- take 1024 manyUsers
|
||||
return $ CourseParticipant bs uid now Nothing Nothing CourseParticipantActive
|
||||
return $ CourseParticipant bs uid now Nothing CourseParticipantActive
|
||||
forM_ [1..14] $ \shNr -> do
|
||||
shId <- insert Sheet
|
||||
{ sheetCourse = bs
|
||||
@ -1141,7 +1147,7 @@ fillDb = do
|
||||
participants <- getRandomR (0, 50)
|
||||
manyUsers' <- shuffleM $ take 1024 manyUsers
|
||||
forM_ (take participants manyUsers') $ \uid ->
|
||||
void . insertUnique $ CourseParticipant cid uid now Nothing Nothing CourseParticipantActive
|
||||
void . insertUnique $ CourseParticipant cid uid now Nothing CourseParticipantActive
|
||||
|
||||
aSeedBig <- liftIO $ getRandomBytes 40
|
||||
bigAlloc <- insert' Allocation
|
||||
@ -1223,7 +1229,6 @@ fillDb = do
|
||||
void $ insert CourseApplication
|
||||
{ courseApplicationCourse = cid
|
||||
, courseApplicationUser = uid
|
||||
, courseApplicationField = Nothing
|
||||
, courseApplicationText = Nothing
|
||||
, courseApplicationRatingVeto = maybe False (view _1) rating
|
||||
, courseApplicationRatingPoints = view _2 <$> rating
|
||||
|
||||
Loading…
Reference in New Issue
Block a user