fradrive/src/Handler/Exam/Users.hs

1209 lines
63 KiB
Haskell

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Exam.Users
( getEUsersR, postEUsersR
) where
import Import hiding ((<.), (.>))
import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Users
import Handler.Utils.Csv
import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget)
import Handler.ExamOffice.Exam (examCloseWidget)
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.HashMap.Lazy as HashMap
import qualified Data.Text as Text
import qualified Data.Text.Encoding 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 Database.Persist.Sql (updateWhereCount)
import Control.Lens.Indexed ((<.), (.>))
import Jobs.Queue
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 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))
, Maybe (Entity CourseUserNote)
)
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 6 1)
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 6 1)
queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
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)
queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus))
queryExamBonus = $(sqlLOJproj 6 4)
queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
queryExamResult = $(sqlLOJproj 6 5)
queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryCourseNote = $(sqlLOJproj 6 6)
queryExamPart :: forall a.
PersistField a
=> ExamPartId
-> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a)))
-> ExamUserTableExpr
-> E.SqlExpr (E.Value a)
queryExamPart epId cont inp = E.subSelectUnsafe . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do
examRegistration <- asks queryExamRegistration
lift $ do
E.on $ E.just (examPart E.^. ExamPartId) E.==. examPartResult E.?. ExamPartResultExamPart
E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (examRegistration E.^. ExamRegistrationUser)
E.where_ $ examPart E.^. ExamPartExam E.==. examRegistration E.^. ExamRegistrationExam
E.&&. examPart E.^. ExamPartId E.==. E.val epId
cont examPart examPartResult
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
resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus)
resultExamBonus = _dbrOutput . _7 . _Just
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
resultExamResult = _dbrOutput . _8 . _Just
resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult))
resultExamParts = _dbrOutput . _9 . 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
resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
resultExamPartResults = resultExamParts <. _2
resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
resultCourseNote = _dbrOutput . _10 . _Just
resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> join $ examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultPassedGrade
resultAutomaticExamResult exam@Exam{..} examBonus' = folding . runReader $ do
parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult))
bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
let gradeRes = examGrade exam bonus =<< parts'
return $ fmap (bool Right (Left . view passingGrade) $ is _ExamGradingPass examGradingMode) <$> gradeRes
csvExamPartHeader :: Prism' Csv.Name ExamPartNumber
csvExamPartHeader = prism' toHeader fromHeader
where
toHeader pName = encodeUtf8 $ partPrefix <> CI.foldedCase (pName ^. _ExamPartNumber)
fromHeader hdr = do
tHdr <- either (const Nothing) Just $ Text.decodeUtf8' hdr
review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr
partPrefix = "part-"
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 (Maybe Points)
, csvEUserExerciseNumPasses :: Maybe (Maybe Int)
, csvEUserExercisePointsMax :: Maybe (Maybe Points)
, csvEUserExerciseNumPassesMax :: Maybe (Maybe Int)
, csvEUserBonus :: Maybe (Maybe Points)
, csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints)
, csvEUserExamResult :: Maybe ExamResultPassedGrade
, csvEUserCourseNote :: Maybe Html
}
deriving (Generic)
makeLenses_ ''ExamUserTableCsv
instance ToNamedRecord ExamUserTableCsv where
toNamedRecord ExamUserTableCsv{..} = Csv.namedRecord $
[ "surname" Csv..= csvEUserSurname
, "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
, fmap ("exercise-num-passes" Csv..=) csvEUserExerciseNumPasses
, fmap ("exercise-points-max" Csv..=) csvEUserExercisePointsMax
, fmap ("exercise-num-passes-max" Csv..=) csvEUserExerciseNumPassesMax
, fmap ("bonus" Csv..=) csvEUserBonus
]
++ examPartResults ++
[ "exam-result" Csv..= csvEUserExamResult
, "course-note" Csv..= csvEUserCourseNote
]
where
examPartResults
= flip ifoldMap csvEUserExamPartResults $
\pNumber pResult -> pure $ (csvExamPartHeader # pNumber) Csv..= pResult
instance FromNamedRecord ExamUserTableCsv where
parseNamedRecord csv
= ExamUserTableCsv
<$> csv .:?? "surname"
<*> 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")
<*> fmap Just (csv .:?? "exercise-points-max")
<*> fmap Just (csv .:?? "exercise-num-passes-max")
<*> fmap Just (csv .:?? "bonus")
<*> examPartResults
<*> csv .:?? "exam-result"
<*> csv .:?? "course-note"
where
examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do
pNumber <- pNumber' ^? csvExamPartHeader
return . fmap (singletonMap pNumber ) $ csv .:?? pNumber'
instance CsvColumnsExplained ExamUserTableCsv where
csvColumnsExplanations _ = mconcat
[ single "surname" MsgCsvColumnExamUserSurname
, 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
, single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax
, single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax
, single "bonus" MsgCsvColumnExamUserBonus
, single "part-*" MsgCsvColumnExamUserParts
, single "exam-result" MsgCsvColumnExamUserResult
, single "course-note" MsgCsvColumnExamUserCourseNote
]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
examUserTableCsvHeader :: ( MonoFoldable mono
, Element mono ~ ExamPartNumber
)
=> SheetGradeSummary -> Bool -> mono -> Csv.Header
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)
++ bool mempty ["exercise-num-passes", "exercise-num-passes-max"] (doBonus && showPasses)
++ bool mempty ["bonus"] doBonus
++ map (review csvExamPartHeader) (sort $ otoList pNames) ++
[ "exam-result"
]
where
showPasses = numSheetsPasses allBoni /= 0
showPoints = getSum (numSheetsPoints allBoni) /= 0
data ExamUserAction = ExamUserDeregister
| ExamUserAssignOccurrence
| ExamUserSetPartResult
| ExamUserSetBonus
| ExamUserSetResult
| ExamUserAcceptComputedResult
| ExamUserResetToComputedResult
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)
| ExamUserSetPartResultData ExamPartNumber (Maybe ExamResultPoints)
| ExamUserSetBonusData (Maybe Points)
| ExamUserSetResultData (Maybe ExamResultPassedGrade)
| ExamUserAcceptComputedResultData
| ExamUserResetToComputedResultData
{ examUserResetBonus :: Bool
}
data ExamUserCsvActionClass
= ExamUserCsvCourseRegister
| ExamUserCsvRegister
| ExamUserCsvAssignOccurrence
| ExamUserCsvSetCourseField
| ExamUserCsvSetPartResult
| ExamUserCsvSetBonus
| ExamUserCsvOverrideBonus
| ExamUserCsvSetResult
| ExamUserCsvOverrideResult
| ExamUserCsvSetCourseNote
| ExamUserCsvDeregister
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
}
| ExamUserCsvSetPartResultData
{ examUserCsvActUser :: UserId
, examUserCsvActExamPart :: ExamPartNumber
, examUserCsvActExamPartResult :: Maybe ExamResultPoints
}
| ExamUserCsvSetBonusData
{ examUserCsvIsBonusOverride :: Bool
, examUserCsvActUser :: UserId
, examUserCsvActExamBonus :: Maybe Points
}
| ExamUserCsvSetResultData
{ examUserCsvIsResultOverride :: Bool
, examUserCsvActUser :: UserId
, examUserCsvActExamResult :: Maybe ExamResultPassedGrade
}
| ExamUserCsvSetCourseNoteData
{ examUserCsvActUser :: UserId
, examUserCsvActCourseNote :: Maybe Html
}
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' 4
, sumEncoding = TaggedObject "action" "data"
} ''ExamUserCsvAction
data ExamUserCsvException
= ExamUserCsvExceptionNoMatchingUser
| ExamUserCsvExceptionMultipleMatchingUsers
| ExamUserCsvExceptionNoMatchingStudyFeatures
| ExamUserCsvExceptionNoMatchingOccurrence
| ExamUserCsvExceptionMismatchedGradingMode ExamGradingMode ExamGradingMode
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
(((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do
exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
occurrences <- selectList [ExamOccurrenceExam ==. eid] [Asc ExamOccurrenceName]
examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
bonus <- examBonus exam
let
allBoni :: SheetGradeSummary
allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
doBonus = is _Just examBonusRule
showPasses = doBonus && numSheetsPasses allBoni /= 0
showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0
examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber
resultAutomaticExamBonus' :: Fold ExamUserTableData Points
resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus
resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultPassedGrade
resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus
automaticCell :: forall msg m a b r.
( RenderMessage UniWorX msg
, IsDBTable m a
, Eq msg
, Monoid b
, a ~ (Any, b)
)
=> Getting (Endo [Either msg msg]) r (Either msg msg)
-> r
-> DBCell m a
automaticCell l r = case toListOf l r of
[] -> mempty
(Left auto : _)
-> i18nCell auto & cellAttrs <>~ [("class", "table__td--automatic")] & tellCell (Any True, mempty)
(Right man : others)
| all ((== man) . either id id) others
-> i18nCell man
| otherwise
-> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] & tellCell (Any True, mempty)
csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
let
examUsersDBTable = DBTable{..}
where
dbtSQLQuery = runReaderT $ do
examRegistration <- asks queryExamRegistration
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
lift $ do
E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse)
E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
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)
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, 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
<*> getExamParts
<*> view _9
where
getExamParts :: ReaderT _ DB (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
getExamParts = do
uid <- view $ _2 . _entityKey
rawResults <- lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do
E.on $ examPartResult E.?. ExamPartResultExamPart E.==. E.just (examPart E.^. ExamPartId)
E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val uid)
E.where_ $ examPart E.^. ExamPartExam E.==. E.val eid
return (examPart, examPartResult)
return $ Map.fromList
[ (epId, (examPart, mbRes))
| (Entity epId examPart, mbRes) <- rawResults
]
dbtColonnade = mconcat $ catMaybes
[ 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
SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus
in propCell (getSum achievedPasses) (getSum numSheetsPasses)
, guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) ->
let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus
SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus
in propCell (getSum achievedPoints) (getSum sumSheetsPoints)
, guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
, pure $ mconcat
[ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
| Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
]
, pure $ sortable (Just "exam-result") (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left)
, pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote))
-> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
]
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
]
, singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)
, singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus)
, sortExamResult (to $ queryExamResult >>> (E.?. ExamResultResult))
, singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
E.subSelectMaybe . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime
]
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
]
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 = mconcat
[ singletonMap ExamUserDeregister $
pure ExamUserDeregisterData
, singletonMap ExamUserAssignOccurrence $
ExamUserAssignOccurrenceData
<$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
, singletonMap ExamUserAcceptComputedResult $
pure ExamUserAcceptComputedResultData
, singletonMap ExamUserResetToComputedResult $
ExamUserResetToComputedResultData
<$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
, singletonMap ExamUserSetPartResult $
ExamUserSetPartResultData
<$> areq (selectField $ optionsPairs (map ((MsgExamPartNumbered &&& id) . examPartNumber . entityVal) examParts)) (fslI MsgExamPart) Nothing
<*> (fmap ExamAttended <$> aopt pointsField (fslI MsgPoints) Nothing)
, singletonMap ExamUserSetBonus $
ExamUserSetBonusData
<$> aopt pointsField (fslI MsgPoints) Nothing
, singletonMap ExamUserSetResult $
ExamUserSetResultData
<$> aopt (examResultModeField (Just $ SomeMessage MsgExamResultNone) examGradingMode) (fslI MsgExamResult) Nothing
]
actionOpts :: Handler (OptionList ExamUserAction)
actionOpts = execWriterT $ do
tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
when (is _Just examGradingRule) $
tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
unless (null examParts) $
tell =<< optionsF [ ExamUserSetPartResult ]
when doBonus $
tell =<< optionsF [ ExamUserSetBonus ]
tell =<< optionsF [ ExamUserSetResult ]
(res, formWgt) <- multiActionMOpts actionMap actionOpts (fslI MsgAction) Nothing csrf
let formRes = (, mempty) . First . Just <$> res
return (formRes, formWgt)
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = _2
, dbParamsFormIdent = def
}
dbtIdent :: Text
dbtIdent = "exam-users"
dbtCsvEncode = Just DBTCsvEncode
{ dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
, dbtCsvName = unpack csvName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
, dbtCsvExampleData = Nothing
}
where
doEncode' = 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)
<*> 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)
<*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped)
<*> fmap (bool (const Nothing) Just showPasses) (preview $ resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral)
<*> fmap (bool (const Nothing) Just doBonus ) (preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus')
<*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
<*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
<*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
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 _}
-> 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
iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
when (epNumber `elem` examPartNumbers) $
yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes)
when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $
yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew
whenIsJust (csvEUserExamResult dbCsvNew) $ \res -> do
yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
guardResultKind res
note <- lift . getBy $ UniqueCourseUserNote uid examCourse
when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $
yield . ExamUserCsvSetCourseNoteData uid $ csvEUserCourseNote 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
Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
let uid = dbCsvOld ^. resultUser . _entityKey
forM_ examPartNumbers $ \epNumber ->
let oldPartResult = dbCsvOld ^? resultExamParts . filtered (views (_1 . _examPartNumber) (== epNumber)) . _2 . _Just . _entityVal . _examPartResultResult
in whenIsJust (csvEUserExamPartResults dbCsvNew !? epNumber) $ \epRes ->
when (epRes /= oldPartResult) $
yield $ ExamUserCsvSetPartResultData uid epNumber epRes
let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
newResults = sequence (csvEUserExamPartResults dbCsvNew)
<|> sequence (toMapOf (resultExamParts .> ito (over _1 examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
newBonus, oldBonus :: Maybe Points
newBonus = join (csvEUserBonus dbCsvNew)
oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus')
newResult, oldResult :: Maybe ExamResultPassedGrade
newResult = fmap (fmap $ bool Right (Left . view passingGrade) $ is _ExamGradingGrades examGradingMode) . examGrade examVal (newBonus <|> oldBonus) =<< newResults
oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
when doBonus $
case newBonus of
_ | newBonus == oldBonus
-> return ()
_ | is _Nothing newBonus
-> return ()
_ | Just ExamBonusManual{} <- examBonusRule
-> yield $ ExamUserCsvSetBonusData False uid newBonus
Nothing
-> yield $ ExamUserCsvSetBonusData False uid newBonus
Just _
-> yield $ ExamUserCsvSetBonusData True uid newBonus
case newResult of
_ | csvEUserExamResult dbCsvNew == oldResult
-> return ()
_ | is _Nothing $ csvEUserExamResult dbCsvNew
-> return ()
Nothing -> do
yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
whenIsJust (csvEUserExamResult dbCsvNew) guardResultKind
Just _
| csvEUserExamResult dbCsvNew /= newResult -> do
yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew
whenIsJust (csvEUserExamResult dbCsvNew) guardResultKind
| oldResult /= newResult -> do
yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
whenIsJust (csvEUserExamResult dbCsvNew) guardResultKind
| otherwise
-> return ()
when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $
yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew
, dbtCsvClassifyAction = \case
ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister
ExamUserCsvRegisterData{} -> ExamUserCsvRegister
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult
ExamUserCsvSetBonusData{..}
| examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus
| otherwise -> ExamUserCsvSetBonus
ExamUserCsvSetResultData{..}
| examUserCsvIsResultOverride -> ExamUserCsvOverrideResult
| otherwise -> ExamUserCsvSetResult
ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote
, dbtCsvCoarsenActionClass = \case
ExamUserCsvCourseRegister -> DBCsvActionNew
ExamUserCsvRegister -> DBCsvActionNew
ExamUserCsvDeregister -> DBCsvActionMissing
_other -> DBCsvActionExisting
, dbtCsvExecuteActions = do
C.mapM_ $ \case
ExamUserCsvCourseRegisterData{..} -> do
now <- liftIO getCurrentTime
void $ upsert
CourseParticipant
{ courseParticipantCourse = examCourse
, courseParticipantUser = examUserCsvActUser
, courseParticipantRegistration = now
, courseParticipantField = examUserCsvActCourseField
, courseParticipantAllocated = Nothing
, courseParticipantState = CourseParticipantActive
}
[ CourseParticipantRegistration =. now
, CourseParticipantField =. examUserCsvActCourseField
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
insert_ ExamRegistration
{ examRegistrationExam = eid
, examRegistrationUser = examUserCsvActUser
, examRegistrationOccurrence = examUserCsvActOccurrence
, examRegistrationTime = now
}
audit $ TransactionExamRegister eid examUserCsvActUser
ExamUserCsvRegisterData{..} -> do
examRegistrationTime <- liftIO getCurrentTime
insert_ ExamRegistration
{ examRegistrationExam = eid
, examRegistrationUser = examUserCsvActUser
, examRegistrationOccurrence = examUserCsvActOccurrence
, ..
}
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
Nothing -> do
deleteBy $ UniqueExamPartResult epid examUserCsvActUser
audit $ TransactionExamPartResultDeleted epid examUserCsvActUser
Just res -> do
now <- liftIO getCurrentTime
void $ upsertBy
(UniqueExamPartResult epid examUserCsvActUser)
(ExamPartResult epid examUserCsvActUser res now)
[ ExamPartResultResult =. res
, ExamPartResultLastChanged =. now
]
audit $ TransactionExamPartResultEdit epid examUserCsvActUser
ExamUserCsvSetBonusData{..} -> case examUserCsvActExamBonus of
Nothing -> do
deleteBy $ UniqueExamBonus eid examUserCsvActUser
audit $ TransactionExamBonusDeleted eid examUserCsvActUser
Just res -> do
now <- liftIO getCurrentTime
void $ upsertBy
(UniqueExamBonus eid examUserCsvActUser)
(ExamBonus eid examUserCsvActUser res now)
[ ExamBonusBonus =. res
, ExamBonusLastChanged =. now
]
audit $ TransactionExamBonusEdit eid examUserCsvActUser
ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
Nothing -> do
deleteBy $ UniqueExamResult eid examUserCsvActUser
audit $ TransactionExamResultDeleted eid examUserCsvActUser
Just res -> do
now <- liftIO getCurrentTime
void $ upsertBy
(UniqueExamResult eid examUserCsvActUser)
(ExamResult eid examUserCsvActUser res now)
[ ExamResultResult =. res
, ExamResultLastChanged =. now
]
audit $ TransactionExamResultEdit eid examUserCsvActUser
ExamUserCsvDeregisterData{..} -> do
ExamRegistration{..} <- getJust examUserCsvActRegistration
deregisterExamUsers examRegistrationExam $ pure examRegistrationUser
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do
noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse
whenIsJust noteId $ \nid -> do
deleteWhere [CourseUserNoteEditNote ==. nid]
delete nid
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do
now <- liftIO getCurrentTime
uid <- liftHandler requireAuthId
Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ]
insert_ $ CourseUserNoteEdit uid now nid
return $ CExamR tid ssh csh examn EUsersR
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
ExamUserCsvCourseRegisterData{..} -> do
(User{..}, occ) <- liftHandler . 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) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe ExamOccurrence{examOccurrenceName} <- occ
\ (#{examOccurrenceName})
$nothing
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvAssignOccurrenceData{..} -> do
occ <- for examUserCsvActOccurrence $ liftHandler . runDB . getJust
[whamlet|
$newline never
^{registeredUserName' examUserCsvActRegistration}
$maybe ExamOccurrence{examOccurrenceName} <- occ
\ (#{examOccurrenceName})
$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
<*> getJustBy (UniqueExamPartNumber eid examUserCsvActExamPart)
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe pName <- examPartName
, #{pName}
$nothing
, _{MsgExamPartNumbered examPartNumber}
$maybe newResult <- examUserCsvActExamPartResult
, _{newResult}
$nothing
, _{MsgExamResultNone}
|]
ExamUserCsvSetBonusData{..} -> do
User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe newBonus <- examUserCsvActExamBonus
, _{newBonus}
$nothing
, _{MsgExamBonusNone}
|]
ExamUserCsvSetResultData{..} -> do
User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe newResult <- examUserCsvActExamResult
, _{newResult}
$nothing
, _{MsgExamResultNone}
|]
ExamUserCsvSetCourseNoteData{..} -> do
User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$if isn't _Just examUserCsvActCourseNote
\ (_{MsgExamUserCsvCourseNoteDeleted})
|]
ExamUserCsvDeregisterData{..}
-> registeredUserName' examUserCsvActRegistration
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
}
where
guardResultKind :: MonadThrow m => ExamResultPassedGrade -> m ()
guardResultKind res
| ( is _ExamGradingPass examGradingMode
&& is (_ExamAttended . _Right) res
) ||
( is _ExamGradingGrades examGradingMode
&& is (_ExamAttended . _Left) res
)
= throwM . ExamUserCsvExceptionMismatchedGradingMode examGradingMode $ if
| is (_ExamAttended . _Left) res -> ExamGradingPass
| otherwise -> ExamGradingGrades
| otherwise = return ()
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{..} = do
let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
, GuessUserDisplayName <$> csvEUserName
, GuessUserSurname <$> csvEUserSurname
, GuessUserFirstName <$> csvEUserFirstName
]
guess <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria (Just 2) -- we're only interested in at most one match, but want to throw an error on multiple matches
pid <- either (const $ throwM ExamUserCsvExceptionMultipleMatchingUsers) (return . entityKey) guess
(,) <$> exists [CourseParticipantCourse ==. examCourse, CourseParticipantUser ==. pid, CourseParticipantState ==. CourseParticipantActive] <*> pure pid
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
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
postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId (Bool, ExamUserTableData) ExamUserTableData) -> FormResult (ExamUserActionData, Map ExamRegistrationId ExamUserTableData)
postprocess inp = do
(First (Just act), regMap) <- inp
let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
return (act, regMap')
(, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
formResult registrationResult $ \case
(ExamUserDeregisterData, Map.elems -> selectedRegistrations) -> do
nrDel <- runDB . setSerializable . deregisterExamUsersCount eId $ map (view $ resultUser . _entityKey) selectedRegistrations
addMessageI Success $ MsgExamUsersDeregistered nrDel
redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do
nrUpdated <- runDB $ updateWhereCount
[ ExamRegistrationId <-. Set.toList selectedRegistrations
]
[ ExamRegistrationOccurrence =. occId
]
addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserAcceptComputedResultData, Map.elems -> rows) -> do
nrAccepted <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do
now <- liftIO getCurrentTime
uid <- view $ resultUser . _entityKey
hasResult <- asks $ has resultExamResult
hasBonus <- asks $ has resultExamBonus
autoResult <- preview $ resultAutomaticExamResult examVal bonus
autoBonus <- preview $ resultAutomaticExamBonus examVal bonus
lift $ if
| not hasResult
, Just examResultResult <- autoResult
-> do
if
| Just examBonusBonus <- autoBonus
, not hasBonus
-> do
insert_ ExamBonus
{ examBonusExam = eId
, examBonusUser = uid
, examBonusLastChanged = now
, ..
}
audit $ TransactionExamBonusEdit eId uid
| otherwise
-> return ()
insert_ ExamResult
{ examResultExam = eId
, examResultUser = uid
, examResultLastChanged = now
, ..
}
audit $ TransactionExamResultEdit eId uid
return $ Sum 1
| otherwise
-> return mempty
addMessageI Success $ MsgExamUsersResultsAccepted nrAccepted
redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserResetToComputedResultData{..}, Map.elems -> rows) -> do
nrReset <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do
uid <- view $ resultUser . _entityKey
lift $ do
when examUserResetBonus $ do
bonusId' <- getKeyBy $ UniqueExamBonus eId uid
whenIsJust bonusId' $ \bonusId -> do
delete bonusId
audit $ TransactionExamBonusDeleted eId uid
result <- getKeyBy $ UniqueExamResult eId uid
case result of
Just resId -> do
delete resId
audit $ TransactionExamResultDeleted eId uid
return $ Sum 1
Nothing -> return mempty
addMessageI Success $ MsgExamUsersResultsReset nrReset
redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserSetPartResultData part mPts, Map.elems -> rows) -> do
now <- liftIO getCurrentTime
updated <- fmap getSum . runDB $ do
partId <- getKeyBy $ UniqueExamPartNumber eId part
flip foldMapM partId $ \epId -> flip foldMapM rows $ \row -> do
let uid = row ^. resultUser . _entityKey
oldPartResult <- getBy $ UniqueExamPartResult epId uid
case mPts of
Just pts
| maybe True ((/= pts) . examPartResultResult . entityVal) oldPartResult -> do
void $ upsert
ExamPartResult
{ examPartResultExamPart = epId
, examPartResultUser = row ^. resultUser . _entityKey
, examPartResultResult = pts
, examPartResultLastChanged = now
}
[ ExamPartResultResult =. pts, ExamPartResultLastChanged =. now ]
audit $ TransactionExamPartResultEdit epId uid
return $ Sum 1
Nothing
| is _Just oldPartResult -> do
deleteBy $ UniqueExamPartResult epId uid
audit $ TransactionExamPartResultDeleted epId uid
return $ Sum 1
_other -> return mempty
addMessageI Success $ MsgExamUsersPartResultsSet updated
redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserSetBonusData mPts, Map.elems -> rows) -> do
now <- liftIO getCurrentTime
updated <- fmap getSum . runDB $ do
flip foldMapM rows $ \row -> do
let uid = row ^. resultUser . _entityKey
oldBonus <- getBy $ UniqueExamBonus eId uid
case mPts of
Just pts
| maybe True ((/= pts) . examBonusBonus . entityVal) oldBonus -> do
void $ upsert
ExamBonus
{ examBonusExam = eId
, examBonusUser = row ^. resultUser . _entityKey
, examBonusBonus = pts
, examBonusLastChanged = now
}
[ ExamBonusBonus =. pts, ExamBonusLastChanged =. now ]
audit $ TransactionExamBonusEdit eId uid
return $ Sum 1
Nothing
| is _Just oldBonus -> do
deleteBy $ UniqueExamBonus eId uid
audit $ TransactionExamBonusDeleted eId uid
return $ Sum 1
_other -> return mempty
addMessageI Success $ MsgExamUsersBonusSet updated
redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserSetResultData mRes, Map.elems -> rows) -> do
now <- liftIO getCurrentTime
updated <- fmap getSum . runDB $ do
flip foldMapM rows $ \row -> do
let uid = row ^. resultUser . _entityKey
oldResult <- getBy $ UniqueExamResult eId uid
case mRes of
Just res
| maybe True ((/= res) . examResultResult . entityVal) oldResult -> do
void $ upsert
ExamResult
{ examResultExam = eId
, examResultUser = row ^. resultUser . _entityKey
, examResultResult = res
, examResultLastChanged = now
}
[ ExamResultResult =. res, ExamResultLastChanged =. now ]
audit $ TransactionExamResultEdit eId uid
return $ Sum 1
Nothing
| is _Just oldResult -> do
deleteBy $ UniqueExamResult eId uid
audit $ TransactionExamResultDeleted eId uid
return $ Sum 1
_other -> return mempty
addMessageI Success $ MsgExamUsersResultSet updated
redirect $ CExamR tid ssh csh examn EUsersR
closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
let computedValuesTip = notificationWidget NotificationBroad Warning
$(i18nWidgetFile "exam-users/computed-values-tip")
$(widgetFile "exam-users")