1136 lines
58 KiB
Haskell
1136 lines
58 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.Utils.StudyFeatures
|
|
|
|
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
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
|
|
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 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 ExamBonus)
|
|
, Maybe (Entity ExamResult)
|
|
, Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))
|
|
, Maybe (Entity CourseUserNote)
|
|
, UserTableStudyFeatures
|
|
)
|
|
|
|
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 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
|
|
|
|
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
|
|
resultExamOccurrence = _dbrOutput . _3 . _Just
|
|
|
|
resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus)
|
|
resultExamBonus = _dbrOutput . _4 . _Just
|
|
|
|
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
|
|
resultExamResult = _dbrOutput . _5 . _Just
|
|
|
|
resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult))
|
|
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 . _6 . unsafeSingular (ix epId) . _2
|
|
|
|
-- resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
|
|
-- resultExamPartResults = resultExamParts <. _2
|
|
|
|
resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
|
|
resultCourseNote = _dbrOutput . _7 . _Just
|
|
|
|
resultStudyFeatures :: Lens' ExamUserTableData UserTableStudyFeatures
|
|
resultStudyFeatures = _dbrOutput . _8
|
|
|
|
|
|
resultAutomaticExamBonus :: Ord epId => Exam -> Map UserId (SheetTypeSummary epId) -> 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 ExamPartId) -> Fold ExamUserTableData ExamResultPassedGrade
|
|
resultAutomaticExamResult exam@Exam{..} examBonus' = folding . runReader $ do
|
|
parts' <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> runMaybeT $ hoistMaybe (mRes ^? _Just . _entityVal . _examPartResultResult)
|
|
<|> MaybeT (preview $ resultAutomaticExamPartResult (Entity epId ep) examBonus')
|
|
)
|
|
bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
|
|
let gradeRes = examGrade exam bonus =<< sequence parts'
|
|
return $ fmap (bool Right (Left . view passingGrade) $ is _ExamGradingPass examGradingMode) <$> gradeRes
|
|
|
|
resultAutomaticExamPartResult :: Entity ExamPart -> Map UserId (SheetTypeSummary ExamPartId) -> Fold ExamUserTableData ExamResultPoints
|
|
resultAutomaticExamPartResult epEnt examBonus' = folding . runReader . runMaybeT $ do
|
|
uid <- view $ resultUser . _entityKey
|
|
summary <- hoistMaybe $ Map.lookup uid examBonus'
|
|
hoistMaybe $ sheetExamResult summary epEnt
|
|
|
|
|
|
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
|
|
, csvEUserStudyFeatures :: UserTableStudyFeatures
|
|
, 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 StoredMarkup
|
|
}
|
|
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
|
|
, "study-features" Csv..= csvEUserStudyFeatures
|
|
, "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"
|
|
<*> pure mempty
|
|
<*> 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 "study-features" MsgCsvColumnUserStudyFeatures
|
|
, 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"
|
|
, "study-features"
|
|
, "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
|
|
, examUserResetParts :: Bool
|
|
}
|
|
|
|
|
|
data ExamUserCsvActionClass
|
|
= ExamUserCsvCourseRegister
|
|
| ExamUserCsvRegister
|
|
| ExamUserCsvAssignOccurrence
|
|
| 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
|
|
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
|
}
|
|
| ExamUserCsvRegisterData
|
|
{ examUserCsvActUser :: UserId
|
|
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
|
}
|
|
| ExamUserCsvAssignOccurrenceData
|
|
{ examUserCsvActRegistration :: ExamRegistrationId
|
|
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
|
|
}
|
|
| 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 StoredMarkup
|
|
}
|
|
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
|
|
Course{..} <- getJust examCourse
|
|
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
|
|
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 $ 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, examBonus', examResult, courseUserNote)
|
|
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
|
|
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
|
|
(,,,,,,,)
|
|
<$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5
|
|
<*> getExamParts
|
|
<*> view _6
|
|
<*> (lift . courseUserStudyFeatures examCourse =<< view (_2 . _entityKey))
|
|
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 $ colStudyFeatures 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) . automaticCell $ resultExamPartResult epId . _Just . _entityVal . _examPartResultResult . to Right <> resultAutomaticExamPartResult epEnt bonus . to Left
|
|
| epEnt@(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
|
|
, 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 ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
|
, fltrExamResultPoints (to $ queryExamResult >>> (E.?. ExamResultResult))
|
|
, fltrRelevantStudyFeaturesTerms (to $
|
|
\t -> ( E.val courseTerm
|
|
, queryUser t E.^. UserId
|
|
))
|
|
, fltrRelevantStudyFeaturesDegree (to $
|
|
\t -> ( E.val courseTerm
|
|
, queryUser t E.^. UserId
|
|
))
|
|
, fltrRelevantStudyFeaturesSemester (to $
|
|
\t -> ( E.val courseTerm
|
|
, queryUser t E.^. UserId
|
|
))
|
|
]
|
|
dbtFilterUI mPrev = mconcat $ catMaybes
|
|
[ Just $ fltrUserNameEmailUI mPrev
|
|
, Just $ fltrUserMatriclenrUI mPrev
|
|
, Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) $ optionsF [CI.original examOccurrenceName | Entity _ ExamOccurrence{..} <- occurrences]) (fslI MsgExamOccurrence)
|
|
, Just $ fltrExamResultPointsUI mPrev
|
|
, Just $ fltrRelevantStudyFeaturesTermsUI mPrev
|
|
, Just $ fltrRelevantStudyFeaturesDegreeUI mPrev
|
|
, Just $ fltrRelevantStudyFeaturesSemesterUI 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)
|
|
<*> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetParts) (Just True)) (not $ all (null . examSummary) bonus)
|
|
, 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)
|
|
<*> view resultStudyFeatures
|
|
<*> 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')
|
|
<*> encodePartResults
|
|
<*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
|
|
<*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
|
|
encodePartResults = fmap Map.fromList . forM examParts $ \epEnt@(Entity epId ExamPart{..}) -> (examPartNumber, ) <$>
|
|
preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult <> resultAutomaticExamPartResult epEnt bonus)
|
|
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
|
|
yieldM $ bool ExamUserCsvCourseRegisterData ExamUserCsvRegisterData isPart uid <$> 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
|
|
|
|
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
|
|
ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult
|
|
ExamUserCsvSetBonusData{..}
|
|
| examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus
|
|
| otherwise -> ExamUserCsvSetBonus
|
|
ExamUserCsvSetResultData{..}
|
|
| examUserCsvIsResultOverride -> ExamUserCsvOverrideResult
|
|
| otherwise -> ExamUserCsvSetResult
|
|
ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote
|
|
, dbtCsvCoarsenActionClass = \case
|
|
ExamUserCsvCourseRegister -> DBCsvActionNew
|
|
ExamUserCsvRegister -> DBCsvActionNew
|
|
ExamUserCsvDeregister -> DBCsvActionMissing
|
|
_other -> DBCsvActionExisting
|
|
, dbtCsvValidateActions = do
|
|
selectedActions <- State.get
|
|
availableActions <- ask
|
|
let missingExamDataUsers = flip filter examDataUsers $ \uid -> any (isRegisterAction uid) availableActions && none (isRegisterAction uid) selectedActions
|
|
where
|
|
examDataUsers = flip mapMaybe selectedActions $ \case
|
|
ExamUserCsvSetResultData{..} -> Just examUserCsvActUser
|
|
ExamUserCsvSetBonusData{..} -> Just examUserCsvActUser
|
|
ExamUserCsvSetPartResultData{..} -> Just examUserCsvActUser
|
|
_other -> Nothing
|
|
isRegisterAction uid = \case
|
|
ExamUserCsvCourseRegisterData{..} -> uid == examUserCsvActUser
|
|
ExamUserCsvRegisterData{..} -> uid == examUserCsvActUser
|
|
_other -> False
|
|
unless (null missingExamDataUsers) $
|
|
tellMPoint $ messageI Error MsgExamUsersExamDataRequiresRegistration
|
|
, dbtCsvExecuteActions = do
|
|
C.mapM_ $ \case
|
|
ExamUserCsvCourseRegisterData{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
void $ upsert
|
|
CourseParticipant
|
|
{ courseParticipantCourse = examCourse
|
|
, courseParticipantUser = examUserCsvActUser
|
|
, courseParticipantRegistration = now
|
|
, courseParticipantAllocated = Nothing
|
|
, courseParticipantState = CourseParticipantActive
|
|
}
|
|
[ CourseParticipantRegistration =. now
|
|
, 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 ]
|
|
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 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})
|
|
|]
|
|
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
|
|
|
|
dbtExtraReps = []
|
|
|
|
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
|
|
autoParts <- asks (itoListOf resultExamParts) >>= mapM (\(epId, (ep, mRes)) -> fmap (guardOnM (isn't _Just mRes) . fmap (epId, )) . preview $ resultAutomaticExamPartResult (Entity epId ep) 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 ()
|
|
|
|
iforM_ (Map.fromList $ catMaybes autoParts) $ \epId autoPartResult -> do
|
|
insert_ ExamPartResult
|
|
{ examPartResultExamPart = epId
|
|
, examPartResultUser = uid
|
|
, examPartResultResult = autoPartResult
|
|
, examPartResultLastChanged = now
|
|
}
|
|
audit $ TransactionExamPartResultEdit epId uid
|
|
|
|
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
|
|
when examUserResetParts $ do
|
|
forM_ (foldMap (Map.keysSet . unMergeMap . examSummary) $ Map.lookup uid bonus) $ \epId -> do
|
|
partResultId' <- getKeyBy $ UniqueExamPartResult epId uid
|
|
whenIsJust partResultId' $ \partResultId -> do
|
|
delete partResultId
|
|
audit $ TransactionExamPartResultDeleted epId 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")
|