{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Handler.Course.Application.List
  ( getCApplicationsR, postCApplicationsR
  ) where

import Import

import Handler.Utils

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 qualified Data.Text as Text
import qualified Data.Text.Lens as Text

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import qualified Data.Map as Map

import qualified Data.Conduit.List as C

import Handler.Course.ParticipantInvite

import Jobs.Queue


type CourseApplicationsTableExpr = (              E.SqlExpr (Entity CourseApplication)
                                    `E.InnerJoin` E.SqlExpr (Entity User)
                                   )
                 `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
                 `E.LeftOuterJoin` (              E.SqlExpr (Maybe (Entity StudyFeatures))
                                    `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
                                    `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
                                   )
                 `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
                                         , Entity User
                                         , Bool -- hasFiles
                                         , Maybe (Entity Allocation)
                                         , Maybe (Entity StudyFeatures)
                                         , Maybe (Entity StudyTerms)
                                         , Maybe (Entity StudyDegree)
                                         , Bool -- isParticipant
                                         )
  
courseApplicationsIdent :: Text
courseApplicationsIdent = "applications"

queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)

queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)

queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
  where
    hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
      E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId

queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
queryAllocation = to $(sqlLOJproj 4 2)

queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)

queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 4 3)

queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 4 3)

queryCourseParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
queryCourseParticipant = to $(sqlLOJproj 4 4)

queryIsParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 4 4)

resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
resultCourseApplication = _dbrOutput . _1

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

resultHasFiles :: Lens' CourseApplicationsTableData Bool
resultHasFiles = _dbrOutput . _3

resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
resultAllocation = _dbrOutput . _4 . _Just

resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures)
resultStudyFeatures = _dbrOutput . _5 . _Just

resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms)
resultStudyTerms = _dbrOutput . _6 . _Just

resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
resultStudyDegree = _dbrOutput . _7 . _Just

resultIsParticipant :: Lens' CourseApplicationsTableData Bool
resultIsParticipant = _dbrOutput . _8


newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
  deriving newtype (Enum, Bounded)
makePrisms ''CourseApplicationsTableVeto

instance Csv.ToField CourseApplicationsTableVeto where
  toField (CourseApplicationsTableVeto True) = "veto"
  toField (CourseApplicationsTableVeto False) = ""

instance Csv.FromField CourseApplicationsTableVeto where
  parseField f = do
    (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
    return . CourseApplicationsTableVeto $ elem t
      [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
  
data CourseApplicationsTableCsv = CourseApplicationsTableCsv
  { csvCAAllocation :: Maybe AllocationShorthand
  , csvCAApplication :: Maybe CryptoFileNameCourseApplication
  , csvCAName :: Maybe Text
  , csvCAMatriculation :: Maybe Text
  , csvCAField :: Maybe Text
  , csvCADegree :: Maybe Text
  , csvCASemester :: Maybe Int
  , csvCAText :: Maybe Text
  , csvCAHasFiles :: Maybe Bool
  , csvCAVeto :: Maybe CourseApplicationsTableVeto
  , csvCARating :: Maybe ExamGrade
  , csvCAComment :: Maybe Text
  } deriving (Generic)
makeLenses_ ''CourseApplicationsTableCsv

courseApplicationsTableCsvOptions :: Csv.Options
courseApplicationsTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 }

instance Csv.ToNamedRecord CourseApplicationsTableCsv where
  toNamedRecord = Csv.genericToNamedRecord courseApplicationsTableCsvOptions

instance Csv.FromNamedRecord CourseApplicationsTableCsv where
  parseNamedRecord csv
    = CourseApplicationsTableCsv
      <$> csv .:?? "allocation"
      <*> csv .:?? "application"
      <*> csv .:?? "name"
      <*> csv .:?? "matriculation"
      <*> csv .:?? "field"
      <*> csv .:?? "degree"
      <*> csv .:?? "semester"
      <*> csv .:?? "text"
      <*> csv .:?? "has-files"
      <*> csv .:?? "veto"
      <*> csv .:?? "rating"
      <*> csv .:?? "comment"

instance Csv.DefaultOrdered CourseApplicationsTableCsv where
  headerOrder = Csv.genericHeaderOrder courseApplicationsTableCsvOptions

instance CsvColumnsExplained CourseApplicationsTableCsv where
  csvColumnsExplanations = genericCsvColumnsExplanations courseApplicationsTableCsvOptions $ Map.fromList
    [ ('csvCAAllocation   , MsgCsvColumnApplicationsAllocation   )
    , ('csvCAApplication  , MsgCsvColumnApplicationsApplication  )
    , ('csvCAName         , MsgCsvColumnApplicationsName         )
    , ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation)
    , ('csvCAField        , MsgCsvColumnApplicationsField        )
    , ('csvCADegree       , MsgCsvColumnApplicationsDegree       )
    , ('csvCASemester     , MsgCsvColumnApplicationsSemester     )
    , ('csvCAText         , MsgCsvColumnApplicationsText         )
    , ('csvCAHasFiles     , MsgCsvColumnApplicationsHasFiles     )
    , ('csvCAVeto         , MsgCsvColumnApplicationsVeto         )
    , ('csvCARating       , MsgCsvColumnApplicationsRating       )
    , ('csvCAComment      , MsgCsvColumnApplicationsComment      )
    ]

data CourseApplicationsTableCsvActionClass
  = CourseApplicationsTableCsvSetField
  | CourseApplicationsTableCsvSetVeto
  | CourseApplicationsTableCsvSetRating
  | CourseApplicationsTableCsvSetComment
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id

data CourseApplicationsTableCsvAction
  = CourseApplicationsTableCsvSetFieldData
    { caCsvActApplication :: CourseApplicationId
    , caCsvActField :: Maybe StudyFeaturesId
    }
  | CourseApplicationsTableCsvSetVetoData
    { caCsvActApplication :: CourseApplicationId
    , caCsvActVeto :: Bool
    }
  | CourseApplicationsTableCsvSetRatingData
    { caCsvActApplication :: CourseApplicationId
    , caCsvActRating :: Maybe ExamGrade
    }
  | CourseApplicationsTableCsvSetCommentData
    { caCsvActApplication :: CourseApplicationId
    , caCsvActComment :: Maybe Text
    }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
  { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 4 . dropEnd 1 . splitCamel
  , fieldLabelModifier = camelToPathPiece' 3
  , sumEncoding = TaggedObject "action" "data"
  } ''CourseApplicationsTableCsvAction

data CourseApplicationsTableCsvException
  = CourseApplicationsTableCsvExceptionNoMatchingUser
  | CourseApplicationsTableCsvExceptionNoMatchingAllocation
  | CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
  deriving (Show, Generic, Typeable)

instance Exception CourseApplicationsTableCsvException

embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id

  
data ButtonAcceptApplications = BtnAcceptApplications
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonAcceptApplications
instance Finite ButtonAcceptApplications

nullaryPathPiece ''ButtonAcceptApplications $ camelToPathPiece' 1

embedRenderMessage ''UniWorX ''ButtonAcceptApplications id
instance Button UniWorX ButtonAcceptApplications where
  btnClasses BtnAcceptApplications = [BCIsButton]

data AcceptApplicationsMode = AcceptApplicationsInvite
                            | AcceptApplicationsDirect
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe AcceptApplicationsMode
instance Finite AcceptApplicationsMode

nullaryPathPiece ''AcceptApplicationsMode $ camelToPathPiece' 2

embedRenderMessage ''UniWorX ''AcceptApplicationsMode id

data AcceptApplicationsSecondary = AcceptApplicationsSecondaryRandom
                                 | AcceptApplicationsSecondaryTime
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe AcceptApplicationsSecondary
instance Finite AcceptApplicationsSecondary

nullaryPathPiece ''AcceptApplicationsSecondary $ camelToPathPiece' 3

embedRenderMessage ''UniWorX ''AcceptApplicationsSecondary id


getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCApplicationsR = postCApplicationsR
postCApplicationsR tid ssh csh = do
  (table, allocationsBounds, mayAccept) <- runDB $ do
    Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh

    csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh)
    let
      allocationLink :: Allocation -> SomeRoute UniWorX
      allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR

      participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
      participantLink uid = do
        cID <- encrypt uid
        return . SomeRoute . CourseR tid ssh csh $ CUserR cID

      applicationLink :: MonadCrypto m => CourseApplicationId -> m (SomeRoute UniWorX)
      applicationLink appId = do
        cID <- encrypt appId
        return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR
      
      dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
      dbtSQLQuery = runReaderT $ do
        courseApplication <- view queryCourseApplication
        hasFiles <- view queryHasFiles
        user <- view queryUser
        allocation <- view queryAllocation
        studyFeatures <- view queryStudyFeatures
        studyTerms <- view queryStudyTerms
        studyDegree <- view queryStudyDegree
        courseParticipant <- view queryCourseParticipant

        lift $ do
          E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser
           E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid)
          E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
          E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
          E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
          E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
          E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
           E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid

        return ( courseApplication
               , user
               , hasFiles
               , allocation
               , studyFeatures
               , studyTerms
               , studyDegree
               , E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
               )

      dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
      dbtProj = runReaderT $ do
        appId <- view $ _dbrOutput . _1 . _entityKey
        cID <- encrypt appId
        
        guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR

        asks $ over (_dbrOutput . _3) E.unValue . over (_dbrOutput . _8) E.unValue

      dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)

      dbtColonnade :: Colonnade Sortable _ _
      dbtColonnade = mconcat
        [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant
        , emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
        , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey)
        , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
        , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
        , emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms
        , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
        , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
        , colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
        , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
        , colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
        , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
        , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
        ]

      dbtSorting = mconcat
        [ singletonMap "participant" . SortColumn $ view queryIsParticipant
        , sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
        , sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
        , sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
        , sortStudyTerms queryStudyTerms
        , sortStudyDegree queryStudyDegree
        , sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
        , sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
        , sortApplicationFiles queryHasFiles
        , sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
        , sortApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
        , sortApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
        ]

      dbtFilter = mconcat
        [ fltrAllocation queryAllocation
        , fltrUserName' $ queryUser . to (E.^. UserDisplayName)
        , fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
        , fltrStudyTerms queryStudyTerms
        , fltrStudyDegree queryStudyDegree
        , fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
        , fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
        , fltrApplicationFiles queryHasFiles
        , fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
        , fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
        , fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
        ]
      dbtFilterUI = mconcat
        [ fltrAllocationUI
        , fltrUserNameUI'
        , fltrUserMatriculationUI
        , fltrStudyTermsUI
        , fltrStudyDegreeUI
        , fltrStudyFeaturesSemesterUI
        , fltrApplicationTextUI
        , fltrApplicationFilesUI
        , fltrApplicationVetoUI
        , fltrApplicationRatingPointsUI
        , fltrApplicationRatingCommentUI
        ]

      dbtStyle = def
        { dbsFilterLayout = defaultDBSFilterLayout
        }
      dbtParams = def

      dbtCsvEncode = simpleCsvEncodeM csvName $ CourseApplicationsTableCsv
        <$> preview (resultAllocation . _entityVal . _allocationShorthand)
        <*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt)
        <*> preview (resultUser . _entityVal . _userDisplayName)
        <*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just)
        <*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey)))
        <*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey)))
        <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
        <*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just)
        <*> preview resultHasFiles
        <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto)
        <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingPoints . _Just)
        <*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingComment . _Just)
      dbtCsvDecode = Just DBTCsvDecode
        { dbtCsvRowKey = \csv -> do
            appRes <- lift $ guessUser csv
            case appRes of
              Right appId -> return $ E.Value appId
              Left uid -> do
                alloc <- lift $ guessAllocation csv
                [appId] <- lift $ selectKeysList [CourseApplicationUser ==. uid, CourseApplicationAllocation ==. alloc] [LimitTo 2]
                return $ E.Value appId
        , dbtCsvComputeActions = \case
            DBCsvDiffMissing{}
              -> return () -- no deletion
            DBCsvDiffNew{}
              -> return () -- no addition
            DBCsvDiffExisting{..} -> do
              let appId = dbCsvOld ^. resultCourseApplication . _entityKey
              
              newFeatures <- lift $ lookupStudyFeatures dbCsvNew
              when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
                yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures

              let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
              whenIsJust mVeto $ \veto -> 
                when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
                  yield $ CourseApplicationsTableCsvSetVetoData appId veto

              when (dbCsvNew ^. _csvCARating /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingPoints) $
                yield $ CourseApplicationsTableCsvSetRatingData appId (dbCsvNew ^. _csvCARating)

              when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $
                yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment)
        , dbtCsvClassifyAction = \case
            CourseApplicationsTableCsvSetFieldData{}   -> CourseApplicationsTableCsvSetField
            CourseApplicationsTableCsvSetVetoData{}    -> CourseApplicationsTableCsvSetVeto
            CourseApplicationsTableCsvSetRatingData{}  -> CourseApplicationsTableCsvSetRating
            CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
        , dbtCsvCoarsenActionClass = const DBCsvActionExisting
        , dbtCsvExecuteActions = do
            now <- liftIO getCurrentTime
            C.mapM_ $ \case
              CourseApplicationsTableCsvSetFieldData{..} -> do
                CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField
                                                                       , CourseApplicationTime =. now
                                                                       ]
                audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
              CourseApplicationsTableCsvSetVetoData{..} -> do
                CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto
                                                                       , CourseApplicationRatingTime =. Just now
                                                                       ]
                audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
              CourseApplicationsTableCsvSetRatingData{..} -> do
                CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingPoints =. caCsvActRating
                                                                       , CourseApplicationRatingTime =. Just now
                                                                       ]
                audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
              CourseApplicationsTableCsvSetCommentData{..} -> do
                CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingComment =. caCsvActComment
                                                                       , CourseApplicationRatingTime =. Just now
                                                                       ]
                audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
            return $ CourseR tid ssh csh CApplicationsR
        , dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case
            CourseApplicationsTableCsvSetFieldData{..} ->
              [whamlet|
                $newline never
                ^{existingApplicantName' caCsvActApplication}
                $maybe features <- caCsvActField
                  , ^{studyFeaturesWidget features}
                $nothing
                  , _{MsgCourseStudyFeatureNone}
              |]
            CourseApplicationsTableCsvSetVetoData{..} ->
              [whamlet|
                $newline never
                ^{existingApplicantName' caCsvActApplication}
                $if caCsvActVeto
                  , _{MsgCourseApplicationVeto}
                $else
                  , _{MsgCourseApplicationNoVeto}
              |]
            CourseApplicationsTableCsvSetRatingData{..} ->
              [whamlet|
                $newline never
                ^{existingApplicantName' caCsvActApplication}
                $maybe newResult <- caCsvActRating
                  , _{newResult}
                $nothing
                  , _{MsgCourseApplicationNoRatingPoints}
              |]
            CourseApplicationsTableCsvSetCommentData{..} ->
              [whamlet|
                $newline never
                ^{existingApplicantName' caCsvActApplication}
                $if is _Nothing caCsvActComment
                  , _{MsgCourseApplicationNoRatingComment}
              |]
        , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
        , dbtCsvRenderException = ap getMessageRender . pure :: CourseApplicationsTableCsvException -> DB Text
        }
        where
          guessUser :: CourseApplicationsTableCsv -> DB (Either UserId CourseApplicationId)
          guessUser csv = do
            mApp <- runMaybeT $ do
              appId <- squash . catchIfMaybeT (const True :: CryptoIDError -> Bool) . MaybeT . traverse decrypt $ csv ^? _csvCAApplication . _Just
              CourseApplication{..} <- MaybeT $ get appId
              guard $ courseApplicationCourse == cid
              return appId

            maybe (Left <$> guessUser' csv) (return . Right) mApp
            where
              guessUser' :: CourseApplicationsTableCsv -> DB UserId
              guessUser' CourseApplicationsTableCsv{..} = $cachedHereBinary (csvCAMatriculation, csvCAName) $ do
                users <- E.select . E.from $ \user -> do
                  E.where_ . E.and $ catMaybes
                    [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvCAMatriculation
                    , (user E.^. UserDisplayName E.==.) . E.val <$> csvCAName
                    ]
                  return $ user E.^. UserId
                case users of
                  [E.Value uid]
                    -> return uid
                  _other
                    -> throwM CourseApplicationsTableCsvExceptionNoMatchingUser

          guessAllocation :: CourseApplicationsTableCsv -> DB (Maybe AllocationId)
          guessAllocation CourseApplicationsTableCsv{..} = $cachedHereBinary csvCAAllocation . for csvCAAllocation $ \ash -> do
            mAlloc <- traverse (getJustEntity . allocationCourseAllocation . entityVal) <=< getBy $ UniqueAllocationCourse cid
            case mAlloc of
              Just (Entity allocId Allocation{..})
                | allocationShorthand == ash
                  -> return allocId
              _other
                -> throwM CourseApplicationsTableCsvExceptionNoMatchingAllocation

          existingApplicantName :: Map (E.Value CourseApplicationId) CourseApplicationsTableData -> CourseApplicationId -> Widget
          existingApplicantName existing (E.Value -> appId) = nameWidget userDisplayName userSurname
            where
              Entity _ User{..} = existing ^. singular (ix appId . resultUser)

          lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId)
          lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do
            appRes <- guessUser csv
            (uid, oldFeatures) <- case appRes of
              Left  uid   -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] []
              Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId
            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 <- csvCAField
                      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 <- csvCADegree
                      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 <$> csvCASemester
                  ]
                E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
                let isActiveOrPrevious = E.or
                      $ (studyFeatures E.^. StudyFeaturesValid)
                      : [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId
                        | Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures
                        ]
                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 csvCAField
                , is _Nothing csvCADegree
                , is _Nothing csvCASemester
                -> return Nothing
              _other
                | [Entity _ CourseApplication{..}] <- oldFeatures
                , Just sfid <- courseApplicationField
                , E.Value sfid `elem` studyFeatures
                -> return $ Just sfid
              _other        -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures


      dbtIdent = courseApplicationsIdent

      psValidator :: PSValidator _ _
      psValidator = def
        & defaultSorting [SortAscBy "user-name"]

    participants <- count [ CourseParticipantCourse ==. cid ]
    let remainingCapacity = subtract participants <$> courseCapacity

    allocationsBounds' <- E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do
      E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
       E.&&. allocationCourse E.^. AllocationCourseCourse E.==. E.val cid

      let numApps addWhere = E.subSelectCount . E.from $ \courseApplication -> do
            E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
                 E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
            addWhere courseApplication

          numApps' = numApps . const $ return ()

          numFirstChoice = numApps $ \courseApplication ->
            E.where_ . E.not_ . E.exists . E.from $ \courseApplication' -> do
              E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. courseApplication' E.^. CourseApplicationAllocation
                   E.&&. courseApplication E.^. CourseApplicationUser       E.==. courseApplication' E.^. CourseApplicationUser
              E.where_ . E.not_ $ E.isNothing (courseApplication E.^. CourseApplicationAllocationPriority)
                            E.||. E.isNothing (courseApplication' E.^. CourseApplicationAllocationPriority)
              E.where_ $ courseApplication' E.^. CourseApplicationAllocationPriority E.>. courseApplication E.^. CourseApplicationAllocationPriority

      return (allocation, numApps', numFirstChoice)

    let
      allocationsBounds = [ (allocation, numApps', numFirstChoice', capped)
                          | (Entity _ allocation, E.Value numApps, E.Value numFirstChoice) <- allocationsBounds'
                          , let numApps' = max 0 $ maybe id min remainingCapacity numApps
                                numFirstChoice' = max 0 $ maybe id min remainingCapacity numFirstChoice
                                capped = numApps' /= numApps
                                      || numFirstChoice' /= numFirstChoice
                          ]

    mayAccept <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR

    (, allocationsBounds, mayAccept) <$> dbTableWidget' psValidator DBTable{..}

  now <- liftIO getCurrentTime
  let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
      registrationOpen = maybe True (now <)

  
  ((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $
    (,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite)
        <*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime)

  let acceptWgt = wrapForm' BtnAcceptApplications acceptWgt' def
        { formSubmit   = FormSubmit
        , formAction   = Just . SomeRoute $ CourseR tid ssh csh CApplicationsR
        , formEncoding = acceptEnc
        }

  when mayAccept $
    formResult acceptRes $ \(invMode, appsSecOrder) -> do
      runDBJobs $ do
        Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
        participants <- count [ CourseParticipantCourse ==. cid ]
        let openCapacity = subtract participants <$> courseCapacity

        applications <- E.select . E.from $ \(user `E.InnerJoin` application) -> do
          E.on $ user E.^. UserId E.==. application E.^. CourseApplicationUser

          E.where_ $ application E.^. CourseApplicationCourse E.==. E.val cid
               E.&&. E.isNothing (application E.^. CourseApplicationAllocation)
               E.&&. E.not_ (application E.^. CourseApplicationRatingVeto)
               E.&&. E.maybe E.true (`E.in_` E.valList (filter (view $ passingGrade . _Wrapped) universeF)) (application E.^. CourseApplicationRatingPoints )

          E.where_ . E.not_ . E.exists . E.from $ \participant ->
            E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
                 E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId

          return (user, application)

        let
          ratingL = _2 . _entityVal . _courseApplicationRatingPoints . to (Down . ExamGradeDefCenter)
          cmp = case appsSecOrder of
            AcceptApplicationsSecondaryTime
              -> comparing . view $ $(multifocusG 2) ratingL (_2 . _entityVal . _courseApplicationTime)
            AcceptApplicationsSecondaryRandom
              -> comparing $ view   ratingL
        sortedApplications <- unstableSortBy cmp applications
  
        let applicants = sortedApplications
                       & nubOn (view $ _1 . _entityKey)
                       & maybe id take openCapacity
                       & setOf (case invMode of
                                  AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right
                                  AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left
                               )
  
        mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants
      redirect $ CourseR tid ssh csh CUsersR


  siteLayoutMsg title $ do
    setTitleI title
    $(widgetFile "course/applications-list")
