603 lines
33 KiB
Haskell
603 lines
33 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Exam.Users
|
|
( getEUsersR, postEUsersR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Lens
|
|
import Handler.Utils
|
|
import Handler.Utils.Exam
|
|
import Handler.Utils.Table.Columns
|
|
import Handler.Utils.Table.Cells
|
|
import Handler.Utils.Csv
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
import Data.Map ((!))
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lens as Text
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Numeric.Lens (integral)
|
|
import Control.Arrow (Kleisli(..))
|
|
|
|
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
|
|
|
|
|
|
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 ExamResult))
|
|
type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult))
|
|
|
|
instance HasEntity ExamUserTableData User where
|
|
hasEntity = _dbrOutput . _2
|
|
|
|
instance HasUser ExamUserTableData where
|
|
hasUser = _dbrOutput . _2 . _entityVal
|
|
|
|
_userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
|
|
_userTableOccurrence = _dbrOutput . _3
|
|
|
|
queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
|
|
|
|
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
|
|
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
|
|
|
|
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
|
|
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
|
|
|
|
queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
|
|
queryExamOccurrence = $(sqlLOJproj 4 2)
|
|
|
|
queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
|
|
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
|
|
|
|
queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
|
|
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
|
|
|
|
queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
|
|
queryExamResult = $(sqlLOJproj 4 4)
|
|
|
|
resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
|
|
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
|
|
|
|
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
|
|
resultExamResult = _dbrOutput . _7 . _Just
|
|
|
|
data ExamUserTableCsv = ExamUserTableCsv
|
|
{ csvEUserSurname :: Maybe Text
|
|
, csvEUserFirstName :: Maybe Text
|
|
, csvEUserName :: Maybe Text
|
|
, csvEUserMatriculation :: Maybe Text
|
|
, csvEUserField :: Maybe Text
|
|
, csvEUserDegree :: Maybe Text
|
|
, csvEUserSemester :: Maybe Int
|
|
, csvEUserOccurrence :: Maybe (CI Text)
|
|
, csvEUserExercisePoints :: Maybe Points
|
|
, csvEUserExerciseNumPasses :: Maybe Int
|
|
, csvEUserExercisePointsMax :: Maybe Points
|
|
, csvEUserExerciseNumPassesMax :: Maybe Int
|
|
, csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
|
|
}
|
|
deriving (Generic)
|
|
makeLenses_ ''ExamUserTableCsv
|
|
|
|
examUserTableCsvOptions :: Csv.Options
|
|
examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
|
|
|
|
instance ToNamedRecord ExamUserTableCsv where
|
|
toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
|
|
|
|
instance FromNamedRecord ExamUserTableCsv where
|
|
parseNamedRecord = Csv.genericParseNamedRecord examUserTableCsvOptions
|
|
|
|
instance DefaultOrdered ExamUserTableCsv where
|
|
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
|
|
|
|
instance CsvColumnsExplained ExamUserTableCsv where
|
|
csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
|
|
[ ('csvEUserSurname , MsgCsvColumnExamUserSurname )
|
|
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
|
|
, ('csvEUserName , MsgCsvColumnExamUserName )
|
|
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
|
|
, ('csvEUserField , MsgCsvColumnExamUserField )
|
|
, ('csvEUserDegree , MsgCsvColumnExamUserDegree )
|
|
, ('csvEUserSemester , MsgCsvColumnExamUserSemester )
|
|
, ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence )
|
|
, ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints )
|
|
, ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses )
|
|
, ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax )
|
|
, ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
|
|
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
|
|
]
|
|
|
|
data ExamUserAction = ExamUserDeregister
|
|
| ExamUserAssignOccurrence
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe ExamUserAction
|
|
instance Finite ExamUserAction
|
|
nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''ExamUserAction id
|
|
|
|
data ExamUserActionData = ExamUserDeregisterData
|
|
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
|
|
|
|
data ExamUserCsvActionClass
|
|
= ExamUserCsvCourseRegister
|
|
| ExamUserCsvRegister
|
|
| ExamUserCsvAssignOccurrence
|
|
| ExamUserCsvSetCourseField
|
|
| ExamUserCsvDeregister
|
|
| ExamUserCsvSetResult
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
|
|
|
|
data ExamUserCsvAction
|
|
= ExamUserCsvCourseRegisterData
|
|
{ examUserCsvActUser :: UserId
|
|
, examUserCsvActCourseField :: Maybe StudyFeaturesId
|
|
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
|
}
|
|
| ExamUserCsvRegisterData
|
|
{ examUserCsvActUser :: UserId
|
|
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
|
}
|
|
| ExamUserCsvAssignOccurrenceData
|
|
{ examUserCsvActRegistration :: ExamRegistrationId
|
|
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
|
}
|
|
| ExamUserCsvSetCourseFieldData
|
|
{ examUserCsvActCourseParticipant :: CourseParticipantId
|
|
, examUserCsvActCourseField :: Maybe StudyFeaturesId
|
|
}
|
|
| ExamUserCsvDeregisterData
|
|
{ examUserCsvActRegistration :: ExamRegistrationId
|
|
}
|
|
| ExamUserCsvSetResultData
|
|
{ examUserCsvActUser :: UserId
|
|
, examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel
|
|
, fieldLabelModifier = camelToPathPiece' 3
|
|
, sumEncoding = TaggedObject "action" "data"
|
|
} ''ExamUserCsvAction
|
|
|
|
data ExamUserCsvException
|
|
= ExamUserCsvExceptionNoMatchingUser
|
|
| ExamUserCsvExceptionNoMatchingStudyFeatures
|
|
| ExamUserCsvExceptionNoMatchingOccurrence
|
|
deriving (Show, Generic, Typeable)
|
|
|
|
instance Exception ExamUserCsvException
|
|
|
|
embedRenderMessage ''UniWorX ''ExamUserCsvException id
|
|
|
|
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
|
getEUsersR = postEUsersR
|
|
postEUsersR tid ssh csh examn = do
|
|
(registrationResult, examUsersTable) <- runDB $ do
|
|
exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
|
|
bonus <- examBonus exam
|
|
|
|
let
|
|
allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
|
|
showPasses = numSheetsPasses allBoni /= 0
|
|
showPoints = getSum (numSheetsPoints allBoni) /= 0
|
|
|
|
resultView :: ExamResultGrade -> Either ExamResultPassed ExamResultGrade
|
|
resultView = bool (Left . over _examResult (view passingGrade)) Right examShowGrades
|
|
|
|
let
|
|
examUsersDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult) = do
|
|
E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
|
|
E.&&. examResult E.?. ExamResultExam 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.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
|
|
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
|
|
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
|
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
|
|
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult)
|
|
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
|
|
dbtProj = return
|
|
dbtColonnade = mconcat $ catMaybes
|
|
[ pure $ dbSelect (applying _2) id $ 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) -> fromMaybe mempty $ do
|
|
SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
|
|
SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
|
|
return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
|
|
, guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
|
|
SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
|
|
SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
|
|
return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
|
|
, guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult)
|
|
, guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade))
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ sortUserNameLink queryUser
|
|
, sortUserMatriclenr queryUser
|
|
, sortField queryStudyField
|
|
, sortDegreeShort queryStudyDegree
|
|
, sortFeaturesSemester queryStudyFeatures
|
|
, ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
|
, ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult))
|
|
, ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50])
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[ fltrUserNameEmail queryUser
|
|
, fltrUserMatriclenr queryUser
|
|
, fltrField queryStudyField
|
|
, fltrDegree queryStudyDegree
|
|
, fltrFeaturesSemester queryStudyFeatures
|
|
, ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
|
, ("result", FilterColumn . E.mkExactFilterWith Just $ queryExamResult >>> (E.?. ExamResultResult))
|
|
, ( "result-bool"
|
|
, FilterColumn $ \row criteria -> if
|
|
| Set.null criteria -> E.true
|
|
| otherwise -> let passed :: [ExamResultGrade]
|
|
passed = filter (\res -> preview (_examResult . passingGrade) res == Just (ExamPassed True)) universeF
|
|
criteria' = Set.map (fmap $ review passingGrade) criteria
|
|
criteria''
|
|
| ExamAttended (ExamPassed True) `Set.member` criteria
|
|
= criteria' `Set.union` Set.fromList passed
|
|
| otherwise
|
|
= criteria'
|
|
in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'')
|
|
)
|
|
]
|
|
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 textField (fslI MsgExamOccurrence)
|
|
, guardOn examShowGrades $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examGradeField) (fslI MsgExamResult)
|
|
, guardOn (not examShowGrades) $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examPassedField) (fslI MsgExamResult)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional = \csrf -> do
|
|
let
|
|
actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
|
|
actionMap = Map.fromList
|
|
[ ( ExamUserDeregister
|
|
, pure ExamUserDeregisterData
|
|
)
|
|
, ( ExamUserAssignOccurrence
|
|
, ExamUserAssignOccurrenceData
|
|
<$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
|
|
)
|
|
]
|
|
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
|
|
let formRes = (, mempty) . First . Just <$> res
|
|
return (formRes, formWgt)
|
|
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtIdent :: Text
|
|
dbtIdent = "exam-users"
|
|
dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
|
|
dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
|
|
<$> view (resultUser . _entityVal . _userSurname . to Just)
|
|
<*> 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)
|
|
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
|
|
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
|
|
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
|
|
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
|
|
<*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
|
|
dbtCsvDecode = Just DBTCsvDecode
|
|
{ dbtCsvRowKey = \csv -> do
|
|
uid <- lift $ view _2 <$> guessUser csv
|
|
fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid
|
|
, dbtCsvComputeActions = \case
|
|
DBCsvDiffMissing{dbCsvOldKey}
|
|
-> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
|
|
DBCsvDiffNew{dbCsvNewKey = Just _}
|
|
-> fail "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 <$> pure uid <*> lookupOccurrence dbCsvNew
|
|
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
|
Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
|
|
when (newFeatures /= oldFeatures) $
|
|
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
|
|
| otherwise ->
|
|
yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
|
|
when (is _Just $ csvEUserExamResult dbCsvNew) $
|
|
yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew
|
|
DBCsvDiffExisting{..} -> do
|
|
newOccurrence <- lift $ lookupOccurrence dbCsvNew
|
|
when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $
|
|
yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence
|
|
|
|
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
|
|
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
|
|
Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
|
|
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
|
|
|
|
when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $
|
|
yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew
|
|
, dbtCsvClassifyAction = \case
|
|
ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister
|
|
ExamUserCsvRegisterData{} -> ExamUserCsvRegister
|
|
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
|
|
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
|
|
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
|
|
ExamUserCsvSetResultData{} -> ExamUserCsvSetResult
|
|
, dbtCsvCoarsenActionClass = \case
|
|
ExamUserCsvCourseRegister -> DBCsvActionNew
|
|
ExamUserCsvRegister -> DBCsvActionNew
|
|
ExamUserCsvDeregister -> DBCsvActionMissing
|
|
_other -> DBCsvActionExisting
|
|
, dbtCsvExecuteActions = do
|
|
C.mapM_ $ \case
|
|
ExamUserCsvCourseRegisterData{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
insert_ CourseParticipant
|
|
{ courseParticipantCourse = examCourse
|
|
, courseParticipantUser = examUserCsvActUser
|
|
, courseParticipantRegistration = now
|
|
, courseParticipantField = examUserCsvActCourseField
|
|
}
|
|
User{userIdent} <- getJust examUserCsvActUser
|
|
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
|
insert_ ExamRegistration
|
|
{ examRegistrationExam = eid
|
|
, examRegistrationUser = examUserCsvActUser
|
|
, examRegistrationOccurrence = examUserCsvActOccurrence
|
|
, examRegistrationTime = now
|
|
}
|
|
ExamUserCsvRegisterData{..} -> do
|
|
examRegistrationTime <- liftIO getCurrentTime
|
|
insert_ ExamRegistration
|
|
{ examRegistrationExam = eid
|
|
, examRegistrationUser = examUserCsvActUser
|
|
, examRegistrationOccurrence = examUserCsvActOccurrence
|
|
, ..
|
|
}
|
|
ExamUserCsvAssignOccurrenceData{..} ->
|
|
update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
|
|
ExamUserCsvSetCourseFieldData{..} ->
|
|
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
|
|
ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
|
|
Nothing -> deleteBy $ UniqueExamResult eid examUserCsvActUser
|
|
Just res -> let res' = either (over _examResult $ review passingGrade) id res
|
|
in void $ upsert
|
|
(ExamResult eid examUserCsvActUser res')
|
|
[ ExamResultResult =. res'
|
|
]
|
|
ExamUserCsvDeregisterData{..} -> do
|
|
ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration
|
|
User{userIdent} <- getJust examRegistrationUser
|
|
audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
|
|
delete examUserCsvActRegistration
|
|
return $ CExamR tid ssh csh examn EUsersR
|
|
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
|
|
ExamUserCsvCourseRegisterData{..} -> do
|
|
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
|
[whamlet|
|
|
$newline never
|
|
^{nameWidget userDisplayName userSurname}
|
|
$maybe features <- examUserCsvActCourseField
|
|
, ^{studyFeaturesWidget features}
|
|
$nothing
|
|
, _{MsgCourseStudyFeatureNone}
|
|
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
|
\ (#{examOccurrenceName})
|
|
$nothing
|
|
\ (_{MsgExamNoOccurrence})
|
|
|]
|
|
ExamUserCsvRegisterData{..} -> do
|
|
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
|
|
[whamlet|
|
|
$newline never
|
|
^{nameWidget userDisplayName userSurname}
|
|
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
|
\ (#{examOccurrenceName})
|
|
$nothing
|
|
\ (_{MsgExamNoOccurrence})
|
|
|]
|
|
ExamUserCsvAssignOccurrenceData{..} -> do
|
|
occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
|
|
[whamlet|
|
|
$newline never
|
|
^{registeredUserName' examUserCsvActRegistration}
|
|
$maybe ExamOccurrence{examOccurrenceName} <- occ
|
|
\ (#{examOccurrenceName})
|
|
$nothing
|
|
\ (_{MsgExamNoOccurrence})
|
|
|]
|
|
ExamUserCsvSetCourseFieldData{..} -> do
|
|
User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
|
|
[whamlet|
|
|
$newline never
|
|
^{nameWidget userDisplayName userSurname}
|
|
$maybe features <- examUserCsvActCourseField
|
|
, ^{studyFeaturesWidget features}
|
|
$nothing
|
|
, _{MsgCourseStudyFeatureNone}
|
|
|]
|
|
ExamUserCsvSetResultData{..} -> do
|
|
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
|
|
[whamlet|
|
|
$newline never
|
|
^{nameWidget userDisplayName userSurname}
|
|
$maybe newResult <- examUserCsvActExamResult
|
|
$case newResult
|
|
$of Left pResult
|
|
, _{pResult}
|
|
$of Right gResult
|
|
, _{gResult}
|
|
$nothing
|
|
, _{MsgExamResultNone}
|
|
|]
|
|
|
|
ExamUserCsvDeregisterData{..}
|
|
-> registeredUserName' examUserCsvActRegistration
|
|
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
|
|
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
|
|
}
|
|
where
|
|
studyFeaturesWidget :: StudyFeaturesId -> Widget
|
|
studyFeaturesWidget featId = do
|
|
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
|
|
[whamlet|
|
|
$newline never
|
|
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|
|
|]
|
|
|
|
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
|
|
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
|
|
where
|
|
Entity _ User{..} = view resultUser $ existing ! registration
|
|
|
|
guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
|
|
guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
|
|
users <- E.select . E.from $ \user -> do
|
|
E.where_ . E.and $ catMaybes
|
|
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
|
|
, (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName
|
|
, (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
|
|
, (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName
|
|
]
|
|
let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
|
|
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
|
|
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
|
|
E.limit 2
|
|
return $ (isCourseParticipant, user E.^. UserId)
|
|
case users of
|
|
(filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)])
|
|
-> return (isPart, uid)
|
|
[(E.Value isPart, E.Value uid)]
|
|
-> return (isPart, uid)
|
|
_other
|
|
-> throwM ExamUserCsvExceptionNoMatchingUser
|
|
|
|
lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
|
|
lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do
|
|
occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] []
|
|
case occIds of
|
|
[occId] -> return occId
|
|
_other -> throwM ExamUserCsvExceptionNoMatchingOccurrence
|
|
|
|
lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
|
|
lookupStudyFeatures csv@ExamUserTableCsv{..} = do
|
|
uid <- view _2 <$> guessUser csv
|
|
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> 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
|
|
E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary
|
|
E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True
|
|
E.limit 2
|
|
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 -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
|
|
|
|
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
|
|
& defaultPagesize PagesizeAll
|
|
|
|
postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId)
|
|
postprocess inp = do
|
|
(First (Just act), regMap) <- inp
|
|
let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
|
|
return (act, regSet)
|
|
over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
|
|
|
|
formResult registrationResult $ \case
|
|
(ExamUserDeregisterData, selectedRegistrations) -> do
|
|
nrDel <- runDB $ deleteWhereCount
|
|
[ ExamRegistrationId <-. Set.toList selectedRegistrations
|
|
]
|
|
addMessageI Success $ MsgExamUsersDeregistered nrDel
|
|
redirect $ CExamR tid ssh csh examn EUsersR
|
|
(ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do
|
|
nrUpdated <- runDB $ updateWhereCount
|
|
[ ExamRegistrationId <-. Set.toList selectedRegistrations
|
|
]
|
|
[ ExamRegistrationOccurrence =. occId
|
|
]
|
|
addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
|
|
redirect $ CExamR tid ssh csh examn EUsersR
|
|
|
|
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
|
|
setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
|
|
$(widgetFile "exam-users")
|