{-# 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.Legacy 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 qualified Data.CaseInsensitive as CI

import qualified Data.Map as Map

import qualified Data.Conduit.List as C

import Handler.Course.ParticipantInvite
import Handler.Utils.StudyFeatures

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 CourseParticipant))
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
                                         , Entity User
                                         , Bool -- hasFiles
                                         , Maybe (Entity Allocation)
                                         , Bool -- isParticipant
                                         , UserTableStudyFeatures
                                         , Bool -- hasAllocationUser
                                         )

courseApplicationsIdent :: Text
courseApplicationsIdent = "applications"

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

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

queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 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 3 2)

queryHasAllocationUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
queryHasAllocationUser = to hasAllocationUser
  where
    hasAllocationUser (view queryCourseApplication -> courseApplication) = E.exists . E.from $ \allocationUser ->
      E.where_ $ E.just (allocationUser E.^. AllocationUserAllocation) E.==. courseApplication E.^. CourseApplicationAllocation
           E.&&. allocationUser E.^. AllocationUserUser E.==. courseApplication E.^. CourseApplicationUser

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

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

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

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

resultStudyFeatures :: Lens' CourseApplicationsTableData UserTableStudyFeatures
resultStudyFeatures = _dbrOutput . _6

resultHasAllocationUser :: Lens' CourseApplicationsTableData Bool
resultHasAllocationUser = _dbrOutput . _7


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
  , csvCAEmail :: Maybe UserEmail
  , csvCAMatriculation :: Maybe Text
  , csvCAStudyFeatures :: UserTableStudyFeatures
  , 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 .:?? "email"
      <*> csv .:?? "matriculation"
      <*> pure mempty
      <*> 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         )
    , ('csvCAEmail        , MsgCsvColumnApplicationsEmail        )
    , ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation)
    , ('csvCAStudyFeatures, MsgCsvColumnUserAppStudyFeatures        )
    , ('csvCAText         , MsgCsvColumnApplicationsText         )
    , ('csvCAHasFiles     , MsgCsvColumnApplicationsHasFiles     )
    , ('csvCAVeto         , MsgCsvColumnApplicationsVeto         )
    , ('csvCARating       , MsgCsvColumnApplicationsRating       )
    , ('csvCAComment      , MsgCsvColumnApplicationsComment      )
    ]

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

data CourseApplicationsTableCsvAction
  = 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
    now <- liftIO getCurrentTime
    Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh

    let
      allocationLink :: Allocation -> SomeRoute UniWorX
      allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR

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

      applicationLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseApplicationId -> m (SomeRoute UniWorX)
      applicationLink appId = liftHandler $ 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
        courseParticipant <- view queryCourseParticipant
        hasAllocationUser <- view queryHasAllocationUser

        lift $ do
          E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser
           E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid)
           E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
          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

          E.where_ $ E.maybe E.true (E.maybe E.false (E.<=. E.val now)) (allocation E.?. AllocationStaffAllocationFrom)

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

      dbtProj :: _ CourseApplicationsTableData
      dbtProj = dbtProjSimple $ \(application, user, E.Value hasFiles, allocation, E.Value isParticipant, E.Value hasAllocationUser) -> do
        feats <- courseUserStudyFeatures (application ^. _entityVal . _courseApplicationCourse) (user ^. _entityKey)
        return (application, user, hasFiles, allocation, isParticipant, feats, hasAllocationUser)

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

      dbtColonnade :: Cornice Sortable ('Cap 'Base) _ _
      dbtColonnade = mconcat
        [ cap (Sortable Nothing generatedColumnsHeader) $ mconcat
          [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant
          , sortable (Just "allocation-short") (i18nCell MsgAllocation) $ \x ->
              let noAllocationUserShort alloc =
                    [whamlet|
                      $newline never
                      <span .allocation--no-allocation-user>
                        #{view _allocationShorthand alloc}
                    |]
                  noAllocationUserTooltip = messageTooltip =<< messageIconI Warning IconNoAllocationUser MsgApplicationAllocationNoAllocationUser
               in if | Just alloc <- x ^? resultAllocation . _entityVal
                     , x ^. resultHasAllocationUser
                       -> anchorCell (allocationLink alloc) $ alloc ^. _allocationShorthand
                     | Just alloc <- x ^? resultAllocation . _entityVal
                       -> anchorCell (allocationLink alloc) (noAllocationUserShort alloc)
                            & cellContents . mapped %~ (<> noAllocationUserTooltip)
                     | otherwise
                       -> mempty
          , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey)
          , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
          , lmap (view $ resultUser . _entityVal) colUserEmail
          , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
          , colStudyFeatures resultStudyFeatures
          ]
        , cap (Sortable Nothing $ i18nCell MsgApplicationUserColumns) $ mconcat
          [ colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
          , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
          ]
        , cap (Sortable Nothing $ i18nCell MsgApplicationRatingColumns) $ mconcat
          [ colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
          , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
          , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
          ]
        ]
        where generatedColumnsHeader = cell $ i18n MsgApplicationGeneratedColumns <> (messageTooltip =<< messageI Info MsgApplicationGeneratedColumnsTip)

      dbtSorting = mconcat
        [ singletonMap "participant" . SortColumn $ view queryIsParticipant
        , sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
        , sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
        , uncurry singletonMap . sortUserEmail $ view queryUser
        , sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
        , 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)
        , uncurry singletonMap . fltrUserEmail $ view queryUser
        , fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
        , fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
        , fltrApplicationFiles queryHasFiles
        , fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
        , fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
        , fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
        , fltrRelevantStudyFeaturesTerms (to $
            \t -> ( E.val courseTerm
                  , views queryUser (E.^. UserId) t
                  ))
        , fltrRelevantStudyFeaturesDegree (to $
            \t -> ( E.val courseTerm
                  , views queryUser (E.^. UserId) t
                  ))
        , fltrRelevantStudyFeaturesSemester (to $
            \t -> ( E.val courseTerm
                  , views queryUser (E.^. UserId) t
                  ))
        ]
      dbtFilterUI = mconcat
        [ fltrAllocationUI
        , fltrUserNameUI'
        , fltrUserMatriculationUI
        , fltrUserEmailUI
        , fltrApplicationTextUI
        , fltrApplicationFilesUI
        , fltrApplicationVetoUI
        , fltrApplicationRatingPointsUI
        , fltrApplicationRatingCommentUI
        , fltrRelevantStudyFeaturesTermsUI
        , fltrRelevantStudyFeaturesDegreeUI
        , fltrRelevantStudyFeaturesSemesterUI
        ]

      dbtStyle = def
        { dbsFilterLayout = defaultDBSFilterLayout
        }
      dbtParams = def

      dbtCsvName = MsgCourseApplicationsTableCsvName tid ssh csh
      dbtCsvSheetName = MsgCourseApplicationsTableCsvSheetName tid ssh csh
      dbtCsvEncode = simpleCsvEncodeM dbtCsvName dbtCsvSheetName $ CourseApplicationsTableCsv
        <$> preview (resultAllocation . _entityVal . _allocationShorthand)
        <*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt)
        <*> preview (resultUser . _entityVal . _userDisplayName)
        <*> preview (resultUser . _entityVal . _userEmail)
        <*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just)
        <*> view resultStudyFeatures
        <*> 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

              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
            CourseApplicationsTableCsvSetVetoData{}    -> CourseApplicationsTableCsvSetVeto
            CourseApplicationsTableCsvSetRatingData{}  -> CourseApplicationsTableCsvSetRating
            CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
        , dbtCsvCoarsenActionClass = const DBCsvActionExisting
        , dbtCsvValidateActions = return ()
        , dbtCsvExecuteActions = do
            C.mapM_ $ \case
              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
            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.^. UserEmail E.==.) . E.val <$> csvCAEmail
                    , (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)

      dbtExtraReps = []

      dbtIdent = courseApplicationsIdent

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

    participants <- count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
    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, CourseParticipantState ==. CourseParticipantActive ]
        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
                 E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive

          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
                       & nubOrdOn (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

  let
    studyFeaturesWarning = $(i18nWidgetFile "applications-list-info")

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