{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Exam.Users
  ( getEUsersR, postEUsersR
  ) where

import Import

import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Table.Columns
import Handler.Utils.Table.Cells
import Handler.Utils.Csv

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH

import qualified Data.Csv as Csv

import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Data.Text as Text
import qualified Data.Text.Lens as Text

import qualified Data.Conduit.List as C

import qualified Data.CaseInsensitive as CI

import Numeric.Lens (integral)

import Database.Persist.Sql (deleteWhereCount, updateWhereCount)


type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `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 ExamResult), 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 5 1)

queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)

queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1)

queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
queryExamOccurrence = $(sqlLOJproj 5 2)

queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)

queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)

queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
queryExamResult = $(sqlLOJproj 5 4)

queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryCourseNote = $(sqlLOJproj 5 5)

resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
resultExamRegistration = _dbrOutput . _1

resultUser :: Lens' ExamUserTableData (Entity User)
resultUser = _dbrOutput . _2

resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
resultStudyFeatures = _dbrOutput . _4 . _Just

resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
resultStudyDegree = _dbrOutput . _5 . _Just

resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
resultStudyField = _dbrOutput . _6 . _Just

resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just

resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
resultExamResult = _dbrOutput . _7 . _Just

resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
resultCourseNote = _dbrOutput . _8 . _Just

data ExamUserTableCsv = ExamUserTableCsv
  { csvEUserSurname :: Maybe Text
  , csvEUserFirstName :: Maybe Text
  , csvEUserName :: Maybe Text
  , csvEUserMatriculation :: Maybe Text
  , csvEUserField :: Maybe Text
  , csvEUserDegree :: Maybe Text
  , csvEUserSemester :: Maybe Int
  , csvEUserOccurrence :: Maybe (CI Text)
  , csvEUserExercisePoints :: Maybe Points
  , csvEUserExerciseNumPasses :: Maybe Int
  , csvEUserExercisePointsMax :: Maybe Points
  , csvEUserExerciseNumPassesMax :: Maybe Int
  , csvEUserExamResult :: Maybe ExamResultPassedGrade
  , csvEUserCourseNote :: Maybe Html
  }
  deriving (Generic)
makeLenses_ ''ExamUserTableCsv

examUserTableCsvOptions :: Csv.Options
examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }

instance ToNamedRecord ExamUserTableCsv where
  toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions

instance FromNamedRecord ExamUserTableCsv where
  parseNamedRecord csv -- Manually defined awaiting issue #427
    = ExamUserTableCsv
      <$> csv .:?? "surname"
      <*> csv .:?? "first-name"
      <*> csv .:?? "name"
      <*> csv .:?? "matriculation"
      <*> csv .:?? "field"
      <*> csv .:?? "degree"
      <*> csv .:?? "semester"
      <*> csv .:?? "occurrence"
      <*> csv .:?? "exercise-points"
      <*> csv .:?? "exercise-num-passes"
      <*> csv .:?? "exercise-points-max"
      <*> csv .:?? "exercise-num-passes-max"
      <*> csv .:?? "exam-result"
      <*> csv .:?? "course-note"

instance DefaultOrdered ExamUserTableCsv where
  headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions

instance CsvColumnsExplained ExamUserTableCsv where
  csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
    [ ('csvEUserSurname             , MsgCsvColumnExamUserSurname           )
    , ('csvEUserFirstName           , MsgCsvColumnExamUserFirstName         )
    , ('csvEUserName                , MsgCsvColumnExamUserName              )
    , ('csvEUserMatriculation       , MsgCsvColumnExamUserMatriculation     )
    , ('csvEUserField               , MsgCsvColumnExamUserField             )
    , ('csvEUserDegree              , MsgCsvColumnExamUserDegree            )
    , ('csvEUserSemester            , MsgCsvColumnExamUserSemester          )
    , ('csvEUserOccurrence          , MsgCsvColumnExamUserOccurrence        )
    , ('csvEUserExercisePoints      , MsgCsvColumnExamUserExercisePoints    )
    , ('csvEUserExerciseNumPasses   , MsgCsvColumnExamUserExercisePasses    )
    , ('csvEUserExercisePointsMax   , MsgCsvColumnExamUserExercisePointsMax )
    , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
    , ('csvEUserExamResult          , MsgCsvColumnExamUserResult            )
    , ('csvEUserCourseNote          , MsgCsvColumnExamUserCourseNote        )
    ]

data ExamUserAction = ExamUserDeregister
                    | ExamUserAssignOccurrence
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

instance Universe ExamUserAction
instance Finite ExamUserAction
nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''ExamUserAction id

data ExamUserActionData = ExamUserDeregisterData
                        | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)

data ExamUserCsvActionClass
  = ExamUserCsvCourseRegister
  | ExamUserCsvRegister
  | ExamUserCsvAssignOccurrence
  | ExamUserCsvSetCourseField
  | ExamUserCsvSetResult
  | 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
    }
  | ExamUserCsvSetResultData
    { 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' 3
  , sumEncoding = TaggedObject "action" "data"
  } ''ExamUserCsvAction

data ExamUserCsvException
  = ExamUserCsvExceptionNoMatchingUser
  | ExamUserCsvExceptionNoMatchingStudyFeatures
  | ExamUserCsvExceptionNoMatchingOccurrence
  deriving (Show, Generic, Typeable)

instance Exception ExamUserCsvException

embedRenderMessage ''UniWorX ''ExamUserCsvException id

getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do
  (registrationResult, examUsersTable) <- runDB $ do
    exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
    bonus <- examBonus exam

    let
      allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
      showPasses     = numSheetsPasses allBoni /= 0
      showPoints     = getSum (numSheetsPoints allBoni) /= 0

      resultView :: ExamResultGrade -> ExamResultPassedGrade
      resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades

    let
      examUsersDBTable = DBTable{..}
        where
          dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = 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 $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
            E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
            E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
            E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
             E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
            E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
             E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
            E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
            E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
            return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote)
          dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
          dbtProj = return
          dbtColonnade = mconcat $ catMaybes
            [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey)
            , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
            , pure   colUserMatriclenr
            , pure $ colField            resultStudyField
            , pure $ colDegreeShort      resultStudyDegree
            , pure $ colFeaturesSemester resultStudyFeatures
            , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
            , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
                SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
                SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
                return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
            , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
                SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
                SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
                return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
            , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult)
            , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade))
            , 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 = Map.fromList
            [ sortUserNameLink     queryUser
            , sortUserMatriclenr   queryUser
            , sortField            queryStudyField
            , sortDegreeShort      queryStudyDegree
            , sortFeaturesSemester queryStudyFeatures
            , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
            , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult))
            , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50])
            , ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
                E.sub_select . 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 = Map.fromList
                    [ ( ExamUserDeregister
                      , pure ExamUserDeregisterData
                      )
                    , ( ExamUserAssignOccurrence
                      , ExamUserAssignOccurrenceData
                        <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
                      )
                    ]
                (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
                let formRes = (, mempty) . First . Just <$> res
                return (formRes, formWgt)
            , dbParamsFormEvaluate = liftHandlerT . runFormPost
            , dbParamsFormResult   = id
            , dbParamsFormIdent    = def
            }
          dbtIdent :: Text
          dbtIdent = "exam-users"
          dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
          dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
            <$> view (resultUser . _entityVal . _userSurname . to Just)
            <*> view (resultUser . _entityVal . _userFirstName . to Just)
            <*> view (resultUser . _entityVal . _userDisplayName . to Just)
            <*> view (resultUser . _entityVal . _userMatrikelnummer)
            <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
            <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
            <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
            <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
            <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
            <*> 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 _}
                  -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
                DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
                  (isPart, uid) <- lift $ guessUser dbCsvNew
                  if
                    | isPart -> do
                        yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
                        newFeatures <- lift $ lookupStudyFeatures dbCsvNew
                        Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
                        when (newFeatures /= oldFeatures) $
                          yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
                    | otherwise ->
                        yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
                  when (is _Just $ csvEUserExamResult dbCsvNew) $
                    yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew

                  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
                    Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
                    yield $ ExamUserCsvSetCourseFieldData cpId newFeatures

                  when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $
                    yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew

                  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
                ExamUserCsvSetResultData{}        -> 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 = False
                      }
                    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
                  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 <- liftHandlerT 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) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
                  [whamlet|
                    $newline never
                    ^{nameWidget userDisplayName userSurname}
                    $maybe features <- examUserCsvActCourseField
                      , ^{studyFeaturesWidget features}
                    $nothing
                      , _{MsgCourseStudyFeatureNone}
                    $maybe ExamOccurrence{examOccurrenceName} <- occ
                      \ (#{examOccurrenceName})
                    $nothing
                      \ (_{MsgExamNoOccurrence})
                  |]
                ExamUserCsvRegisterData{..} -> do
                  (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
                  [whamlet|
                    $newline never
                    ^{nameWidget userDisplayName userSurname}
                    $maybe ExamOccurrence{examOccurrenceName} <- occ
                      \ (#{examOccurrenceName})
                    $nothing
                      \ (_{MsgExamNoOccurrence})
                  |]
                ExamUserCsvAssignOccurrenceData{..} -> do
                  occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
                  [whamlet|
                    $newline never
                    ^{registeredUserName' examUserCsvActRegistration}
                    $maybe ExamOccurrence{examOccurrenceName} <- occ
                      \ (#{examOccurrenceName})
                    $nothing
                      \ (_{MsgExamNoOccurrence})
                  |]
                ExamUserCsvSetCourseFieldData{..} -> do
                  User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
                  [whamlet|
                    $newline never
                    ^{nameWidget userDisplayName userSurname}
                    $maybe features <- examUserCsvActCourseField
                      , ^{studyFeaturesWidget features}
                    $nothing
                      , _{MsgCourseStudyFeatureNone}
                  |]
                ExamUserCsvSetResultData{..} -> do
                  User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
                  [whamlet|
                    $newline never
                    ^{nameWidget userDisplayName userSurname}
                    $maybe newResult <- examUserCsvActExamResult
                      , _{newResult}
                    $nothing
                      , _{MsgExamResultNone}
                  |]
                ExamUserCsvSetCourseNoteData{..} -> do
                  User{..} <- liftHandlerT . 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{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
                users <- E.select . E.from $ \user -> do
                  E.where_ . E.and $ catMaybes
                    [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
                    , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName
                    , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
                    , (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName
                    ]
                  let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
                        E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
                             E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
                  E.limit 2
                  return (isCourseParticipant, user E.^. UserId)
                case users of
                  (filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)])
                    -> return (isPart, uid)
                  [(E.Value isPart, E.Value uid)]
                    -> return (isPart, uid)
                  _other
                    -> throwM ExamUserCsvExceptionNoMatchingUser

              lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
              lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do
                occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] []
                case occIds of
                  [occId] -> return occId
                  _other  -> throwM ExamUserCsvExceptionNoMatchingOccurrence

              lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
              lookupStudyFeatures csv@ExamUserTableCsv{..} = do
                uid <- view _2 <$> guessUser csv
                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) -> FormResult (ExamUserActionData, Set ExamRegistrationId)
      postprocess inp = do
        (First (Just act), regMap) <- inp
        let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
        return (act, regSet)
    over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable

  formResult registrationResult $ \case
    (ExamUserDeregisterData, selectedRegistrations) -> do
      nrDel <- runDB $ deleteWhereCount
        [ ExamRegistrationId <-. Set.toList selectedRegistrations
        ]
      addMessageI Success $ MsgExamUsersDeregistered nrDel
      redirect $ CExamR tid ssh csh examn EUsersR
    (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do
      nrUpdated <- runDB $ updateWhereCount
        [ ExamRegistrationId <-. Set.toList selectedRegistrations
        ]
        [ ExamRegistrationOccurrence =. occId
        ]
      addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
      redirect $ CExamR tid ssh csh examn EUsersR

  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
    setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
    $(widgetFile "exam-users")
