1095 lines
58 KiB
Haskell
1095 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.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 (deleteWhereCount, 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 -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
|
|
|
|
resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade
|
|
resultAutomaticExamResult exam examBonus' = folding . runReader $ do
|
|
parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult))
|
|
bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
|
|
return $ examGrade exam bonus =<< parts'
|
|
|
|
|
|
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
|
|
| 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)
|
|
| 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
|
|
| ExamUserCsvExceptionNoMatchingStudyFeatures
|
|
| ExamUserCsvExceptionNoMatchingOccurrence
|
|
deriving (Show, Generic, Typeable)
|
|
|
|
instance Exception ExamUserCsvException
|
|
|
|
embedRenderMessage ''UniWorX ''ExamUserCsvException id
|
|
|
|
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
|
getEUsersR = postEUsersR
|
|
postEUsersR tid ssh csh examn = do
|
|
(((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do
|
|
exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
|
|
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
|
|
|
|
resultView :: ExamResultGrade -> ExamResultPassedGrade
|
|
resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
|
|
|
|
examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber
|
|
|
|
resultAutomaticExamBonus' :: Fold ExamUserTableData Points
|
|
resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus
|
|
resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade
|
|
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.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 _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
|
|
getExamParts = do
|
|
uid <- view $ _2 . _entityKey
|
|
rawResults <- lift . 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 $ bool "result-bool" "result" examShowGrades) (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) . to (bimap resultView resultView)
|
|
, 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)
|
|
, singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
|
|
, singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
|
|
, 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 = Map.fromList
|
|
[ fltrUserNameEmail queryUser
|
|
, fltrUserMatriclenr queryUser
|
|
, fltrField queryStudyField
|
|
, fltrDegree queryStudyDegree
|
|
, fltrFeaturesSemester queryStudyFeatures
|
|
, ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
|
, ("result", FilterColumn . E.mkExactFilterWith Just $ queryExamResult >>> (E.?. ExamResultResult))
|
|
, ( "result-bool"
|
|
, FilterColumn $ \row criteria -> if
|
|
| Set.null criteria -> E.true
|
|
| otherwise -> let passed :: [ExamResultGrade]
|
|
passed = filter (\res -> preview (_examResult . passingGrade) res == Just (ExamPassed True)) universeF
|
|
criteria' = Set.map (fmap $ review passingGrade) criteria
|
|
criteria''
|
|
| ExamAttended (ExamPassed True) `Set.member` criteria
|
|
= criteria' `Set.union` Set.fromList passed
|
|
| otherwise
|
|
= criteria'
|
|
in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'')
|
|
)
|
|
]
|
|
dbtFilterUI mPrev = mconcat $ catMaybes
|
|
[ Just $ fltrUserNameEmailUI mPrev
|
|
, Just $ fltrUserMatriclenrUI mPrev
|
|
, Just $ fltrFieldUI mPrev
|
|
, Just $ fltrDegreeUI mPrev
|
|
, Just $ fltrFeaturesSemesterUI mPrev
|
|
, Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
|
|
, guardOn examShowGrades $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examGradeField) (fslI MsgExamResult)
|
|
, guardOn (not examShowGrades) $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examPassedField) (fslI MsgExamResult)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional = \csrf -> do
|
|
let
|
|
actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
|
|
actionMap = mconcat
|
|
[ singletonMap ExamUserDeregister $
|
|
pure ExamUserDeregisterData
|
|
, singletonMap ExamUserAssignOccurrence $
|
|
ExamUserAssignOccurrenceData
|
|
<$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
|
|
, bool mempty computeActionMap $ is _Just examGradingRule
|
|
]
|
|
computeActionMap = mconcat
|
|
[ singletonMap ExamUserAcceptComputedResult $
|
|
pure ExamUserAcceptComputedResultData
|
|
, singletonMap ExamUserResetToComputedResult $
|
|
ExamUserResetToComputedResultData
|
|
<$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
|
|
]
|
|
(res, formWgt) <- multiActionM actionMap (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
|
|
}
|
|
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)
|
|
<*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints)
|
|
<*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
|
|
<*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints)
|
|
<*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
|
|
<*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus)
|
|
<*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
|
|
<*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView
|
|
<*> 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 <$> pure 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
|
|
|
|
when (is _Just $ csvEUserExamResult dbCsvNew) $
|
|
yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
|
|
|
|
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 resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults
|
|
oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView
|
|
|
|
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
|
|
-> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
|
|
Just _
|
|
| csvEUserExamResult dbCsvNew /= newResult
|
|
-> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew
|
|
| oldResult /= newResult
|
|
-> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
|
|
| 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
|
|
insert_ CourseParticipant
|
|
{ courseParticipantCourse = examCourse
|
|
, courseParticipantUser = examUserCsvActUser
|
|
, courseParticipantRegistration = now
|
|
, courseParticipantField = examUserCsvActCourseField
|
|
, courseParticipantAllocated = Nothing
|
|
}
|
|
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
|
|
let res' = either (review passingGrade) id <$> res
|
|
now <- liftIO getCurrentTime
|
|
void $ upsertBy
|
|
(UniqueExamResult eid examUserCsvActUser)
|
|
(ExamResult eid examUserCsvActUser res' now)
|
|
[ ExamResultResult =. res'
|
|
, ExamResultLastChanged =. now
|
|
]
|
|
audit $ TransactionExamResultEdit eid examUserCsvActUser
|
|
ExamUserCsvDeregisterData{..} -> do
|
|
ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration
|
|
audit $ TransactionExamDeregister eid examRegistrationUser
|
|
delete examUserCsvActRegistration
|
|
result <- getBy $ UniqueExamResult eid examRegistrationUser
|
|
forM_ result $ \(Entity erId _) -> do
|
|
delete erId
|
|
audit $ TransactionExamResultDeleted eid 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
|
|
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 = Set.fromList $ catMaybes
|
|
[ GuessUserMatrikelnummer <$> csvEUserMatriculation
|
|
, GuessUserDisplayName <$> csvEUserName
|
|
, GuessUserSurname <$> csvEUserSurname
|
|
, GuessUserFirstName <$> csvEUserFirstName
|
|
]
|
|
pid <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria
|
|
(,) <$> existsBy (UniqueParticipant pid examCourse) <*> 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.keysSet -> selectedRegistrations) -> do
|
|
nrDel <- runDB $ deleteWhereCount
|
|
[ ExamRegistrationId <-. Set.toList 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
|
|
|
|
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")
|