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

module Handler.Course.Users
  ( queryUser
  , makeCourseUserTable
  , postCUsersR, getCUsersR
  , colUserSex', _userStudyFeatures
  ) where

import Import

import Utils.Form
import Handler.Utils
import Handler.Utils.Course
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH

import Handler.Course.Register (deregisterParticipant)
import Handler.Utils.StudyFeatures

import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Database.Esqueleto.Legacy as E

import qualified Data.Csv as Csv

import qualified Data.Conduit.List as C

import qualified Data.CaseInsensitive as CI

import Database.Persist.Sql (updateWhereCount)

import Handler.Sheet.PersonalisedFiles

import qualified Data.Text.Lazy as Lazy (Text)

import qualified Data.Aeson as JSON


type UserTableExpr   = (               E.SqlExpr (Entity User)
                         `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)
                       )
     `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
     `E.LeftOuterJoin` (               E.SqlExpr (Maybe (Entity SubmissionGroup))
                         `E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionGroupUser))
                       )

-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
-- forceUserTableType = id

-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
-- This ought to ease refactoring the query
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)

queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)

queryUserNote ::  UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryUserNote = $(sqlLOJproj 3 2)

querySubmissionGroup :: UserTableExpr -> E.SqlExpr (Maybe (Entity SubmissionGroup))
querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 3 3)


userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
                                                          , E.SqlExpr (Entity CourseParticipant)
                                                          , E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
                                                          , E.SqlExpr (Maybe (Entity SubmissionGroup))
                                                          )
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` (subGroup `E.InnerJoin` subGroupUser)) = do
  -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
  E.on $ subGroup E.?. SubmissionGroupId E.==. subGroupUser E.?. SubmissionGroupUserSubmissionGroup
  E.on $ subGroupUser E.?. SubmissionGroupUserUser E.==. E.just (user E.^. UserId)
   E.&&. subGroup E.?. SubmissionGroupCourse E.==. E.just (E.val cid)
  E.on $  (note E.?. CourseUserNoteUser   E.==. E.just (participant E.^. CourseParticipantUser))
    E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
  E.on $     participant E.^. CourseParticipantUser   E.==. user E.^. UserId
  E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
  return (user, participant, note E.?. CourseUserNoteId, subGroup)


type UserTableData = DBRow ( Entity User
                           , Entity CourseParticipant
                           , Maybe CourseUserNoteId
                           , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
                           , [Entity Exam]
                           , Maybe (Entity SubmissionGroup)
                           , Map SheetName (SheetType SqlBackendKey, Maybe Points)
                           , UserTableStudyFeatures
                           )

instance HasEntity UserTableData User where
  hasEntity = _dbrOutput . _1

instance HasUser UserTableData where
  hasUser = _dbrOutput . _1 . _entityVal

_userTableParticipant :: Lens' UserTableData (Entity CourseParticipant)
_userTableParticipant = _dbrOutput . _2

_userTableRegistration :: Lens' UserTableData UTCTime
_userTableRegistration = _userTableParticipant . _entityVal . _courseParticipantRegistration

_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3

_userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
_userTutorials = _dbrOutput . _4

_userExams :: Lens' UserTableData [Entity Exam]
_userExams = _dbrOutput . _5

_userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup)
_userSubmissionGroup = _dbrOutput . _6 . _Just

_userSheets :: Lens' UserTableData (Map SheetName (SheetType SqlBackendKey, Maybe Points))
_userSheets = _dbrOutput . _7

_userStudyFeatures :: Lens' UserTableData UserTableStudyFeatures
_userStudyFeatures = _dbrOutput . _8


colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh =
    sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) ->
                                                                                                                           maybeEmpty mbNoteKey $ const $
         anchorCellM (courseLink <$> encrypt uid) (hasComment True)
  where
    courseLink = CourseR tid ssh csh . CUserR

colUserTutorials :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserTutorials tid ssh csh = sortable (Just "tutorials") (i18nCell MsgCourseUserTutorials)
  $ \(view _userTutorials -> tuts') ->
    let tuts = sortOn (tutorialName . entityVal) $ (tuts' ^. _1) ++ (tuts' ^.. _2 . folded . _Just)
     in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell tuts $ anchorCell'
          (\(Entity _ Tutorial{..}) -> CTutorialR tid ssh csh tutorialName TUsersR)
          (tutorialName . entityVal)

colUserExams :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams)
  $ \(view _userExams -> exams') ->
    let exams = sortOn (examName . entityVal) exams'
     in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell exams $ anchorCell'
          (\(Entity _ Exam{..}) -> CExamR tid ssh csh examName EUsersR)
          (examName . entityVal)

colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSex' = colUserSex $ hasUser . _userSex

colUserSubmissionGroup :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSubmissionGroup = sortable (Just "submission-group") (i18nCell MsgTableSubmissionGroup) $
  foldMap (cell . toWidget) . preview (_userSubmissionGroup . _entityVal . _submissionGroupName)

colUserSheets :: forall m c. IsDBTable m c => [SheetName] -> Cornice Sortable ('Cap 'Base) UserTableData (DBCell m c)
colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
  where
    caption = i18nCell MsgCourseUserSheets
      & cellAttrs <>~ [ ("uw-hide-column-header", "sheets")
                      , ("uw-hide-column-default-hidden", "")
                      ]

    userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
    userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) $ \dat -> flip (views $ _userSheets . at shn) dat $ \case
      Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgTableAchievedOf points maxPoints
      Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points
      _other -> mempty


data UserTableCsv = UserTableCsv
  { csvUserSurname :: UserSurname
  , csvUserFirstName :: UserFirstName
  , csvUserName :: UserDisplayName
  , csvUserSex :: Maybe Sex
  , csvUserMatriculation :: Maybe UserMatriculation
  , csvUserEmail :: UserEmail
  , csvUserStudyFeatures :: UserTableStudyFeatures
  , csvUserSubmissionGroup :: Maybe SubmissionGroupName
  , csvUserRegistration :: UTCTime
  , csvUserNote :: Maybe StoredMarkup
  , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName))
  , csvUserExams :: [ExamName]
  , csvUserSheets :: Map SheetName (SheetType (), Maybe Points)
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLenses_ ''UserTableCsv

instance Csv.ToNamedRecord UserTableCsv where
  toNamedRecord UserTableCsv{..} = Csv.namedRecord $
    [ "surname" Csv..= csvUserSurname
    , "first-name" Csv..= csvUserFirstName
    , "name" Csv..= csvUserName
    , "sex" Csv..= csvUserSex
    , "matriculation" Csv..= csvUserMatriculation
    , "email" Csv..= csvUserEmail
    , "study-features" Csv..= csvUserStudyFeatures
    , "submission-group" Csv..= csvUserSubmissionGroup
    , "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1)
    ] ++
    [ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut)
    | (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2
    ] ++
    [ "exams" Csv..= CsvSemicolonList csvUserExams
    , "registration" Csv..= csvUserRegistration
    ] ++
    [ encodeUtf8 (CI.foldedCase shn) Csv..= res
    | (shn, res) <- Map.toList csvUserSheets
    ] ++
    [ "note" Csv..= csvUserNote
    ]
instance CsvColumnsExplained UserTableCsv where
  csvColumnsExplanations _ = mconcat
    [ single "surname"             MsgCsvColumnUserSurname
    , single "first-name"          MsgCsvColumnUserFirstName
    , single "name"                MsgCsvColumnUserName
    , single "sex"                 MsgCsvColumnUserSex
    , single "matriculation"       MsgCsvColumnUserMatriculation
    , single "email"               MsgCsvColumnUserEmail
    , single "study-features"      MsgCsvColumnUserCourseStudyFeatures
    , single "submission-group"    MsgCsvColumnUserSubmissionGroup
    , single "tutorial"            MsgCsvColumnUserTutorial
    , single "exams"               MsgCsvColumnUserExam
    , single "registration"        MsgCsvColumnUserRegistration
    , single "note"                MsgCsvColumnUserNote
    ]
    where
      single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
      single k v = singletonMap k [whamlet|_{v}|]

newtype UserCsvExportData = UserCsvExportData
  { csvUserIncludeSheets :: Bool
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Default UserCsvExportData where
  def = UserCsvExportData False

userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExportData -> Csv.Header
userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $
  [ "surname", "first-name", "name" ] ++
  [ "sex" | showSex ] ++
  [ "matriculation", "email", "study-features"] ++
  [ "tutorial" | hasEmptyRegGroup ] ++
  map (encodeUtf8 . CI.foldedCase) regGroups ++
  [ "exams", "registration" ] ++
  guardOnM csvUserIncludeSheets [ encodeUtf8 $ CI.foldedCase sheetName | Entity _ Sheet{..} <- sheets ] ++
  [ "note" ]
  where
    hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts
    regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts

data UserTableJson = UserTableJson
  { jsonUserSurname :: UserSurname
  , jsonUserFirstName :: UserFirstName
  , jsonUserName :: UserDisplayName
  , jsonUserSex :: Maybe (Maybe Sex)
  , jsonUserMatriculation :: Maybe UserMatriculation
  , jsonUserEmail :: UserEmail
  , jsonUserStudyFeatures :: UserTableStudyFeatures
  , jsonUserSubmissionGroup :: Maybe SubmissionGroupName
  , jsonUserRegistration :: UTCTime
  , jsonUserNote :: Maybe Lazy.Text
  , jsonUserTutorials :: Set TutorialName
  , jsonUserTutorialGroups :: Map (CI Text) (Maybe TutorialName)
  , jsonUserExams :: Set ExamName
  , jsonUserSheets :: Map SheetName UserTableJsonSheetResult
  } deriving (Generic, Typeable)

data UserTableJsonSheetResult = UserTableJsonSheetResult
  { jsonSheetType :: SheetType UserTableJsonSheetTypeExamPartRef
  , jsonPoints :: Maybe Points
  } deriving (Generic, Typeable)

data UserTableJsonSheetTypeExamPartRef = UserTableJsonSheetTypeExamPartRef
  { jsonExam :: ExamName
  , jsonExamPart :: ExamPartNumber
  } deriving (Generic, Typeable)

deriveToJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''UserTableJsonSheetTypeExamPartRef

deriveToJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''UserTableJsonSheetResult

instance ToJSON UserTableJson where
  toJSON UserTableJson{..} = JSON.object $ catMaybes
    [ pure $ "surname" JSON..= jsonUserSurname
    , pure $ "first-name" JSON..= jsonUserFirstName
    , pure $ "name" JSON..= jsonUserName
    , ("sex" JSON..=) <$> jsonUserSex
    , ("matriculation" JSON..=) <$> jsonUserMatriculation
    , pure $ "email" JSON..= jsonUserEmail
    , ("study-features" JSON..=) <$> assertM' (views _Wrapped $ not . onull) jsonUserStudyFeatures
    , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup
    , pure $ "registration" JSON..= jsonUserRegistration
    , ("note" JSON..=) <$> jsonUserNote
    , ("tutorials" JSON..=) <$> assertM' (not . onull) jsonUserTutorials
    , ("tutorial-groups" JSON..=) <$> assertM' (any $ is _Just) jsonUserTutorialGroups
    , ("exams" JSON..=) <$> assertM' (not . onull) jsonUserExams
    , ("sheets" JSON..=) <$> assertM' (any $ has (to jsonPoints . _Just)) jsonUserSheets
    ]

data CourseUserAction = CourseUserSendMail
                      | CourseUserRegisterTutorial
                      | CourseUserRegisterExam
                      | CourseUserSetSubmissionGroup
                      | CourseUserReRegister
                      | CourseUserDeregister
                      | CourseUserDownloadPersonalisedSheetFiles
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)

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

data CourseUserActionData = CourseUserSendMailData
                          | CourseUserDeregisterData
                            { deregisterSelfImposed :: Maybe (Text, Bool {- no-show -})
                            }
                          | CourseUserRegisterTutorialData
                            { registerTutorial :: TutorialId
                            }
                          | CourseUserRegisterExamData
                            { registerExam :: (ExamId, Maybe ExamOccurrenceId)
                            }
                          | CourseUserSetSubmissionGroupData
                            { setSubmissionGroup :: Maybe SubmissionGroupName
                            }
                          | CourseUserReRegisterData
                          | CourseUserDownloadPersonalisedSheetFilesData
                            { downloadPersonalisedFilesForSheet :: SheetName
                            , downloadPersonalisedFilesAnonMode :: PersonalisedSheetFilesDownloadAnonymous
                            }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)


makeCourseUserTable :: forall h p cols act act'.
                       ( Functor h, ToSortable h
                       , Ord act, PathPiece act, RenderMessage UniWorX act
                       , AsCornice h p UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))) cols
                       )
                    => CourseId
                    -> Map act (AForm Handler act')
                    -> (UserTableExpr -> E.SqlExpr (E.Value Bool))
                    -> cols
                    -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))
                    -> Maybe (Csv.Name -> Bool)
                    -> DB (FormResult (act', Set UserId), Widget)
makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
    currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute
    Course{..} <- getJust cid
    tutorials <- selectList [ TutorialCourse ==. cid ] []
    exams <- selectList [ ExamCourse ==. cid ] []
    sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
    personalisedSheets <- E.select . E.from $ \sheet -> do
      let hasPersonalised = E.exists . E.from $ \psFile ->
            E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
      E.where_ $ E.not_ (sheet E.^. SheetAllowNonPersonalisedSubmission)
           E.||. hasPersonalised
      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
      E.orderBy [ E.desc $ sheet E.^. SheetActiveTo
                , E.desc $ sheet E.^. SheetActiveFrom
                ]
      return $ sheet E.^. SheetName
    -- -- psValidator has default sorting and filtering
    showSex <- getShowSex
    let dbtIdent     = "courseUsers" :: Text
        dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
        dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
        dbtRowKey    = queryUser >>> (E.^. UserId)
        dbtProj      = dbtProjSimple $ \(user, participant, E.Value userNoteId, subGroup) -> do
          tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
          exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
          subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
            E.on $ submissionUser E.?. SubmissionUserSubmission E.==. submission E.?. SubmissionId
            E.on $ E.just (sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
             E.&&. submissionUser E.?. SubmissionUserUser E.==. E.just (E.val $ entityKey user)
            E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
            return ( sheet E.^. SheetName
                   , ( sheet E.^. SheetType
                     , submission
                     )
                   )
          feats <- courseUserStudyFeatures (participant ^. _entityVal . _courseParticipantCourse) (participant ^. _entityVal . _courseParticipantUser)
          let
            regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
            tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials
            tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts'
            exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams
            subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs'
          return (user, participant, userNoteId, tuts, exs, subGroup, subs, feats)
        dbtColonnade = colChoices
        dbtSorting   = mconcat
          [ single $ sortUserNameLink    queryUser -- slower sorting through clicking name column header
          , single $ sortUserSurname     queryUser -- needed for initial sorting
          , single $ sortUserDisplayName queryUser -- needed for initial sorting
          , single $ sortUserEmail       queryUser
          , single $ sortUserMatriclenr  queryUser
          , sortUserSex (to queryUser . to (E.^. UserSex))
          , single ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
          , single ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
                E.subSelectMaybe . E.from $ \edit -> do
                  E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
                  return . E.max_ $ edit E.^. CourseUserNoteEditTime
            )
          , single ("tutorials"   , SortColumn $ queryUser >>> \user ->
                E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
                  E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
                   E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
                  E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
                  return . E.min_ $ tutorial E.^. TutorialName
            )
          , single ("exams"       , SortColumn $ queryUser >>> \user ->
                E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
                  E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
                   E.&&. exam E.^. ExamCourse E.==. E.val cid
                  E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
                  return . E.min_ $ exam E.^. ExamName
            )
          , single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
          , single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
          , mconcat
            [ single ( SortingKey $ "sheet-" <> sheetName
                     , SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
                         E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
                         E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
                         E.where_ $ submission E.^. SubmissionSheet E.==. E.val shId
                         return $ submission E.^. SubmissionRatingPoints

                     )
            | Entity shId Sheet{..} <- sheets
            ]
          ]
          where single = uncurry Map.singleton
        dbtFilter    = mconcat
          [ single $ fltrUserNameLink    queryUser
          , single $ fltrUserEmail       queryUser
          , single $ fltrUserMatriclenr  queryUser
          , single $ fltrUserNameEmail   queryUser
          , fltrUserSex (to queryUser . to (E.^. UserSex))
          , single ("tutorial"    , FilterColumn $ E.mkExistsFilter   $ \row criterion ->
                         E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
                           E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
                           E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
                                E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
                                E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
                     )
          , single ("exam"        , FilterColumn $ E.mkExistsFilter $ \row criterion ->
                         E.from $ \(exam `E.InnerJoin` examRegistration) -> do
                           E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
                           E.where_ $ exam E.^. ExamCourse E.==. E.val cid
                                E.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
                                E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId
                     )
          -- , ("course-registration", error "TODO") -- TODO
          -- , ("course-user-note", error "TODO") -- TODO
          , single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
          , single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
          , single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
                     -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
                          E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
                          E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
                          E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
                               E.&&. sheet E.^. SheetName E.==. E.val shn
                   )
          , fltrRelevantStudyFeaturesTerms (to $
              \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
                    , queryUser t E.^. UserId
                    ))
          , fltrRelevantStudyFeaturesDegree (to $
              \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
                    , queryUser t E.^. UserId
                    ))
          , fltrRelevantStudyFeaturesSemester (to $
              \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
                    , queryUser t E.^. UserId
                    ))
          ]
          where single = uncurry Map.singleton
        dbtFilterUI mPrev = mconcat $
          [ prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt (courseParticipantStateIsActiveField . Just $ SomeMessage MsgTableNoFilter) (fslI MsgCourseParticipantStateIsActiveFilter)
          , fltrUserNameEmailUI  mPrev
          , fltrUserMatriclenrUI mPrev
          ] ++
          [ fltrUserSexUI mPrev | showSex ] ++
          [ prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup)
          , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial)
          , prismAForm (singletonFilter "exam")     mPrev $ aopt textField (fslI MsgCourseUserExam)
          , fltrRelevantStudyFeaturesDegreeUI mPrev
          , fltrRelevantStudyFeaturesTermsUI mPrev
          , fltrRelevantStudyFeaturesSemesterUI mPrev
          ] ++
          [ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter)
          | not $ null personalisedSheets
          ]
        dbtParams    = DBParamsForm
          { dbParamsFormMethod = POST
          , dbParamsFormAction = Just $ SomeRoute currentRoute
          , dbParamsFormAttrs  = []
          , dbParamsFormSubmit = FormSubmit
          , dbParamsFormAdditional
              = renderAForm FormStandard
                   $  (, mempty) . First . Just
                  <$> multiActionA acts (fslI MsgTableAction) Nothing
          , dbParamsFormEvaluate = liftHandler . runFormPost
          , dbParamsFormResult   = id
          , dbParamsFormIdent    = def
          }
        dbtCsvName = MsgCourseUserCsvName courseTerm courseSchool courseShorthand
        dbtCsvSheetName = MsgCourseUserCsvSheetName courseTerm courseSchool courseShorthand
        dbtCsvEncode = do
          csvColumns' <- csvColumns
          return $ DBTCsvEncode
            { dbtCsvExportForm = UserCsvExportData
                <$> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def)
            , dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(_, row) -> flip runReaderT row $
                UserTableCsv
                  <$> view (hasUser . _userSurname)
                  <*> view (hasUser . _userFirstName)
                  <*> view (hasUser . _userDisplayName)
                  <*> view (hasUser . _userSex)
                  <*> view (hasUser . _userMatrikelnummer)
                  <*> view (hasUser . _userEmail)
                  <*> view _userStudyFeatures
                  <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
                  <*> view _userTableRegistration
                  <*> userNote
                  <*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials)
                  -- <*> (over (_2.traverse._Just) (examName . entityVal) . over (_1.traverse) (examName . entityVal) <$> view _userExams)
                  <*> (over traverse (examName . entityVal) <$> view _userExams)
                  <*> views _userSheets (set (mapped . _1 . mapped) ())
            , dbtCsvName, dbtCsvSheetName
            , dbtCsvNoExportData = Nothing
            , dbtCsvHeader = return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def
            , dbtCsvExampleData = Nothing
            }
        userNote = runMaybeT $ do
          noteId <- MaybeT . preview $ _userTableNote . _Just
          CourseUserNote{..} <- lift . lift $ getJust noteId
          return courseUserNoteNote
        dbtCsvDecode = Nothing
        dbtExtraReps = withCsvExtraRep dbtCsvSheetName (UserCsvExportData True) dbtCsvEncode
          [ DBTExtraRep $ toPrettyJSON <$> repUserJson, DBTExtraRep $ toYAML <$> repUserJson
          ]

        repUserJson :: ConduitT (E.Value UserId, UserTableData) Void DB (Map CryptoUUIDUser UserTableJson)
        repUserJson = C.foldMapM $ \(E.Value uid, res) -> Map.singleton <$> encrypt uid <*> mkUserTableJson res
          where
            mkUserTableJson res' = flip runReaderT res' $ UserTableJson
              <$> view (hasUser . _userSurname)
              <*> view (hasUser . _userFirstName)
              <*> view (hasUser . _userDisplayName)
              <*> views (hasUser . _userSex) (guardOn showSex)
              <*> view (hasUser . _userMatrikelnummer)
              <*> view (hasUser . _userEmail)
              <*> view _userStudyFeatures
              <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
              <*> view _userTableRegistration
              <*> (fmap markupInput <$> userNote)
              <*> view (_userTutorials . _1 . folded . to (Set.singleton . tutorialName . entityVal))
              <*> views (_userTutorials . _2) (over (traverse . _Just) $ tutorialName . entityVal)
              <*> view (_userExams . folded . to (Set.singleton . examName . entityVal))
              <*> (fmap (fmap $ uncurry UserTableJsonSheetResult) . traverseOf (traverse . _1) (lift . resolveSheetType') =<< view _userSheets)
            resolveSheetType' sType = do
              sType' <- resolveSheetType cid sType
              for sType' $ \(Entity _ ExamPart{..}) -> do
                Exam{..} <- getJust examPartExam
                return $ UserTableJsonSheetTypeExamPartRef examName examPartNumber
    over _1 postprocess <$> dbTable psValidator DBTable{..}
  where
    postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId)
    postprocess inp = do
      (First (Just act), usrMap) <- inp
      let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
      return (act, usrSet)

courseUserDeregisterForm :: CourseId -> AForm Handler CourseUserActionData
courseUserDeregisterForm cid = wFormToAForm $ do
  allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant ->
    E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
         E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated)
         E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
  if | allocated -> do
         wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip
         let selfImposedForm = (,)
               <$> apreq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing
               <*> apopt checkBoxField (fslI MsgCourseDeregistrationAllocationNoShow & setTooltip MsgCourseDeregistrationAllocationNoShowTip) Nothing
         fmap CourseUserDeregisterData <$> optionalActionW selfImposedForm (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
     | otherwise -> pure . pure $ CourseUserDeregisterData Nothing

getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = postCUsersR
postCUsersR tid ssh csh = do
  showSex <- getShowSex
  (course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do
    mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
    ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
    hasTutorials <- exists [TutorialCourse ==. cid]
    examOccurrencesPerExam <- E.select . E.from $ \(exam `E.LeftOuterJoin` examOccurrence) -> do
      E.on $ E.just (exam E.^. ExamId) E.==. examOccurrence E.?. ExamOccurrenceExam
      E.where_ $ exam E.^. ExamCourse E.==. E.val cid
      return (exam, examOccurrence)
    hasSubmissionGroups <- E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` courseParticipant) -> do
      E.on $ courseParticipant E.^. CourseParticipantUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser
       E.&&. courseParticipant E.^. CourseParticipantCourse E.==. submissionGroup E.^. SubmissionGroupCourse
      E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
      E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
    sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
    personalisedSheets <- E.select . E.from $ \sheet -> do
      let hasPersonalised = E.exists . E.from $ \psFile ->
            E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
      E.where_ $ E.not_ (sheet E.^. SheetAllowNonPersonalisedSubmission)
           E.||. hasPersonalised
      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
      E.orderBy [ E.desc $ sheet E.^. SheetActiveTo
                , E.desc $ sheet E.^. SheetActiveFrom
                ]
      return $ sheet E.^. SheetName
    let exams = nubOrdOn entityKey $ examOccurrencesPerExam ^.. folded . _1
    let colChoices  = mconcat $ catMaybes
          [ pure . cap' $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR)
          , guardOn showSex . cap' $ colUserSex'
          , pure . cap' $ colUserEmail
          , pure . cap' $ colUserMatriclenr
          , pure . cap' $ colStudyFeatures _userStudyFeatures
          , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
          , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
          , guardOn hasExams . cap' $ colUserExams tid ssh csh
          , pure . cap' $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive))
          , pure . cap' $ sortable (Just "state") (i18nCell MsgCourseUserState) (i18nCell . view (_userTableParticipant . _entityVal . _courseParticipantState))
          , guardOn (not $ null sheetList) . colUserSheets $ map (sheetName . entityVal) sheetList
          , pure . cap' $ colUserComment tid ssh csh
          ]
        psValidator = def & defaultSortingByName
                          & defaultFilter (singletonMap "active" [toPathPiece True])
        hasExams = not $ null exams
        examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
        examOccActs = examOccurrencesPerExam
          & map (bimap entityKey hoistMaybe)
          & Map.fromListWith (<>)
          & imap (\k v -> case v of
            [] -> pure (k, Nothing)
            _  -> (k,) <$> aopt (selectField' (Just $ SomeMessage MsgExamNoOccurrence) $ examOccOpts v) (fslI MsgTableExamOccurrence) (Just Nothing)
            )
          where
            examOccOpts :: [Entity ExamOccurrence] -> Handler (OptionList ExamOccurrenceId)
            examOccOpts examOccs = fmap mkOptionList . forM examOccs $ \Entity{..} -> do
              optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExamOccurrence
              let
                optionExternalValue = toPathPiece optionExternalValue'
                optionInternalValue = entityKey
                optionDisplay       = CI.original $ examOccurrenceName entityVal
              return Option{..}
        examActs :: Handler (OptionList ExamId)
        examActs = fmap mkOptionList . forM exams $ \Entity{..} -> do
          optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExam
          let
            optionExternalValue = toPathPiece optionExternalValue'
            optionInternalValue = entityKey
            optionDisplay       = CI.original $ examName entityVal
          return Option{..}
        submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
        acts :: Map CourseUserAction (AForm Handler CourseUserActionData)
        acts = mconcat $ catMaybes
          [ pure . singletonMap CourseUserSendMail $ pure CourseUserSendMailData
          , pure . singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData
              <$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
                        (fslI MsgCourseTutorial)
                        Nothing
          , pure . singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$>
              multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing
          , pure . singletonMap CourseUserSetSubmissionGroup $ CourseUserSetSubmissionGroupData . assertM (not . Text.null . CI.original)
              <$> aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgTableSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
          , guardOn mayRegister . singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
          , guardOn mayRegister . singletonMap CourseUserReRegister $ pure CourseUserReRegisterData
          , guardOn (not $ null personalisedSheets) . singletonMap CourseUserDownloadPersonalisedSheetFiles $
                  CourseUserDownloadPersonalisedSheetFilesData
              <$> apopt (selectField' Nothing . optionsF $ map E.unValue personalisedSheets) (fslI MsgExerciseSheet) Nothing
              <*> apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField) (Just PersonalisedSheetFilesDownloadAnonymous)
          ]
    numParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
    table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True)
    return (ent, numParticipants, table)
  formResult participantRes $ \case
    (CourseUserSendMailData, selectedUsers) -> do
        cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
        redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
    (CourseUserDeregisterData{..}, selectedUsers) -> do
        Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
          now <- liftIO getCurrentTime
          Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
          unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid"
          lift $ deregisterParticipant courseParticipantUser course
          case deregisterSelfImposed of
            Just (reason, noShow)
              | is _Just courseParticipantAllocated -> lift $ do
                  insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
                  updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ]
                  let recordNoShow eId = do
                        didRecord <- is _Just <$> insertUnique ExamResult
                          { examResultExam = eId
                          , examResultUser = uid
                          , examResultResult = ExamNoShow
                          , examResultLastChanged = now
                          }
                        when didRecord $
                          audit $ TransactionExamResultEdit eId uid
                  when noShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow
            _other -> return ()
          return 1
        addMessageI Success $ MsgCourseUsersDeregistered nrDel
        redirect $ CourseR tid ssh csh CUsersR
    (CourseUserRegisterTutorialData{..}, selectedUsers) -> do
        runDB . forM_ selectedUsers $
          void . insertUnique . TutorialParticipant registerTutorial
        addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
        redirect $ CourseR tid ssh csh CUsersR
    (CourseUserRegisterExamData{..}, selectedUsers) -> do
        Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do
          guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
          now <- liftIO getCurrentTime
          let (exam, mOccurrence) = registerExam
          mExamReg <- lift $ insertUnique ExamRegistration
            { examRegistrationExam       = exam
            , examRegistrationUser       = uid
            , examRegistrationOccurrence = mOccurrence
            , examRegistrationTime       = now
            }
          case mExamReg of
            Just _ -> do
              lift . audit $ TransactionExamRegister exam uid
              return 1
            Nothing ->
              return mempty
        addMessageI Success $ MsgCourseUsersExamRegistered nrReg
        redirect $ CourseR tid ssh csh CUsersR
    (CourseUserSetSubmissionGroupData{..}, selectedUsers) -> do
      nrSet <- runDB $ setUsersSubmissionGroup cid selectedUsers setSubmissionGroup

      case setSubmissionGroup of
        Nothing -> addMessageI Success $ MsgCourseUsersSubmissionGroupUnset  nrSet
        Just _  -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet

      redirect $ CourseR tid ssh csh CUsersR
    (CourseUserReRegisterData, selectedUsers) -> do
      now <- liftIO getCurrentTime
      Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
        didUpdate <- lift $ updateWhereCount
          [ CourseParticipantUser ==. uid
          , CourseParticipantCourse ==. cid
          , CourseParticipantState !=. CourseParticipantActive
          ]
          [ CourseParticipantState =. CourseParticipantActive
          , CourseParticipantRegistration =. now
          , CourseParticipantAllocated =. Nothing
          ]
        guard $ didUpdate > 0
        lift $ deleteWhere [ AllocationDeregisterCourse ==. Just cid, AllocationDeregisterUser ==. uid ]
        lift . audit $ TransactionCourseParticipantEdit cid uid
        return $ Sum didUpdate
      addMessageI Success $ MsgCourseUsersStateSet nrSet
      redirect $ CourseR tid ssh csh CUsersR
    (CourseUserDownloadPersonalisedSheetFilesData shn anonMode, selectedUsers) -> do
      shId <- runDB . getKeyBy404 $ CourseSheet cid shn
      archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $
        MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand shn
      sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cid (Just shId) (Just selectedUsers) anonMode Set.empty


  let headingLong  = [whamlet|_{MsgHeadingCourseMembers} #{courseName} #{tid}|]
      headingShort = prependCourseTitle tid ssh csh MsgHeadingCourseMembers
  siteLayout headingLong $ do
    setTitleI headingShort
    $(widgetFile "course-participants")
