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

module Handler.Course.Users
  ( queryUser
  , makeCourseUserTable
  , postCUsersR, getCUsersR
  , colUserDegreeShort, colUserField, colUserSemester, colUserSex'
  ) where

import Import

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

import Handler.Course.Register (deregisterParticipant)

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 as E

import qualified Data.Csv as Csv

import qualified Data.Conduit.List as C

import qualified Data.CaseInsensitive as CI


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 StudyFeatures))
                         `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
                         `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
                       )

-- 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)

queryFeaturesStudy ::  UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryFeaturesStudy  = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)

queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)

queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryFeaturesField  = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)


userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
                                                          , E.SqlExpr (E.Value UTCTime)
                                                          , E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
                                                          , StudyFeaturesDescription')
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
  -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
  features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
  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 E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)


type UserTableData = DBRow ( Entity User
                           , UTCTime
                           , Maybe CourseUserNoteId
                           , (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
                           , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
                           )

instance HasEntity UserTableData User where
  hasEntity = _dbrOutput . _1

instance HasUser UserTableData where
  -- hasUser = _entityVal
  hasUser = _dbrOutput . _1 . _entityVal

_userTableRegistration :: Lens' UserTableData UTCTime
_userTableRegistration = _dbrOutput . _2

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

_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
_userTableFeatures = _dbrOutput . _4

_rowUserSemester :: Traversal' UserTableData Int
_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester

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


colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh =
    sortable (Just "note") (i18nCell MsgCourseUserNote)
      $ \DBRow{ dbrOutput=(Entity 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)

colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
    foldMap numCell . preview _rowUserSemester

colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
    foldMap i18nCell . view (_userTableFeatures . _3)

-- colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-- colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
--     foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3)

-- colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-- colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
--     foldMap i18nCell . preview (_userTableFeatures . _2 . _Just)

colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
    foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)

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


data UserTableCsvStudyFeature = UserTableCsvStudyFeature
  { csvUserField :: Text
  , csvUserDegree :: Text
  , csvUserSemester :: Int
  , csvUserType :: StudyFieldType
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLenses_ ''UserTableCsvStudyFeature
  
data UserTableCsv = UserTableCsv
  { csvUserName :: Text
  , csvUserSex :: Maybe Sex
  , csvUserMatriculation :: Maybe Text
  , csvUserEmail :: CI Email
  , csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature)
  , csvUserRegistration :: UTCTime
  , csvUserNote :: Maybe Html
  , csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName))
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLenses_ ''UserTableCsv

instance Csv.ToNamedRecord UserTableCsv where
  toNamedRecord UserTableCsv{..} = Csv.namedRecord $
    [ "name" Csv..= csvUserName
    , "sex" Csv..= csvUserSex
    , "matriculation" Csv..= csvUserMatriculation
    , "email" Csv..= csvUserEmail
    ] ++ case csvUserStudyFeatures of
           Left feats
             -> [ "field"    Csv..= (csvUserField    <$> feats)
                , "degree"   Csv..= (csvUserDegree   <$> feats)
                , "semester" Csv..= (csvUserSemester <$> feats)
                ]
           Right feats
             -> let featsStr = Text.intercalate "; " . flip map (Set.toList feats) $ \UserTableCsvStudyFeature{..}
                      -> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType
                          in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|]
                 in [ "study-features" Csv..= featsStr
                    ]
      ++
    [ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1
       in "tutorial" Csv..= tutsStr
    ] ++
    [ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut)
    | (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2
    ] ++
    [ "registration" Csv..= csvUserRegistration
    , "note" Csv..= csvUserNote
    ]
instance CsvColumnsExplained UserTableCsv where
  csvColumnsExplanations _ = mconcat
    [ single "name"                MsgCsvColumnUserName
    , single "sex"                 MsgCsvColumnUserSex
    , single "matriculation"       MsgCsvColumnUserMatriculation
    , single "email"               MsgCsvColumnUserEmail
    , single "study-features"      MsgCsvColumnUserStudyFeatures
    , single "field"               MsgCsvColumnUserField
    , single "degree"              MsgCsvColumnUserDegree
    , single "semester"            MsgCsvColumnUserSemester
    , single "tutorial"            MsgCsvColumnUserTutorial
    , 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
  { csvUserSimplifiedFeaturesOfStudy :: Bool
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Default UserCsvExportData where
  def = UserCsvExportData True

userTableCsvHeader :: Bool -> UserCsvExportData -> [Entity Tutorial] -> Csv.Header
userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $
  [ "name" ] ++
  [ "sex" | showSex ] ++
  [ "matriculation", "email"
  ] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++
  [ "tutorial" | hasEmptyRegGroup ] ++
  map (encodeUtf8 . CI.foldedCase) regGroups ++
  [ "registration", "note"
  ]
  where
    hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts
    regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts


data CourseUserAction = CourseUserSendMail
                      | CourseUserDeregister
                      | CourseUserRegisterTutorial
  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
                            { deregisterReason :: Maybe Text
                            }
                          | CourseUserRegisterTutorialData
                            { registerTutorial :: TutorialId
                            }
  deriving (Eq, Ord, Read, Show, Generic, Typeable)


makeCourseUserTable :: forall h act act'.
                       ( Functor h, ToSortable h
                       , Ord act, PathPiece act, RenderMessage UniWorX act
                       )
                    => CourseId
                    -> Map act (AForm Handler act')
                    -> (UserTableExpr -> E.SqlExpr (E.Value Bool))
                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData)))
                    -> 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
    csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand)
    tutorials <- selectList [ TutorialCourse ==. cid ] []
    -- -- 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      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> do
          tuts'' <- lift $ selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
          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'
          return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts)
        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 $ ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
          , single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
          , single $ ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
          , single $ ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
          , single $ ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
          , 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
            )
          ]
          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 $ ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
          , single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
          , single $ ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
          , single $ ("field"       , FilterColumn $ E.anyFilter
                                        [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
                                        , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
                                        , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
                                        ] )
          , single $ ("degree"      , FilterColumn $ E.anyFilter
                                        [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
                                        , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
                                        , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
                                        ] )
          , single $ ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
          , 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
                     )
          -- , ("course-registration", error "TODO") -- TODO
          -- , ("course-user-note", error "TODO") -- TODO
          ]
          where single = uncurry Map.singleton
        dbtFilterUI mPrev = mconcat $
          [ fltrUserNameEmailUI  mPrev
          , fltrUserMatriclenrUI mPrev
          ] ++
          [ fltrUserSexUI mPrev | showSex ] ++
          [ prismAForm (singletonFilter "degree")   mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
          , prismAForm (singletonFilter "field")    mPrev $ aopt textField (fslI MsgCourseStudyFeature)
          , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial)
          ]
        dbtParams    = DBParamsForm
          { dbParamsFormMethod = POST
          , dbParamsFormAction = Just $ SomeRoute currentRoute
          , dbParamsFormAttrs  = []
          , dbParamsFormSubmit = FormSubmit
          , dbParamsFormAdditional
              = renderAForm FormStandard
                   $  (, mempty) . First . Just
                  <$> multiActionA acts (fslI MsgAction) Nothing
          , dbParamsFormEvaluate = liftHandler . runFormPost
          , dbParamsFormResult   = id
          , dbParamsFormIdent    = def
          }
        dbtCsvEncode = do
          csvColumns' <- csvColumns
          return $ DBTCsvEncode
            { dbtCsvExportForm = UserCsvExportData
                <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
            , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ 
                UserTableCsv
                  <$> view (hasUser . _userDisplayName)
                  <*> view (hasUser . _userSex)
                  <*> view (hasUser . _userMatrikelnummer)
                  <*> view (hasUser . _userEmail)
                  <*> if
                        | csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $
                            UserTableCsvStudyFeature
                              <$> MaybeT (preview $   _userTableFeatures . _3 . _Just . _studyTermsName . _Just
                                                   <> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow
                                         )
                              <*> MaybeT (preview $   _userTableFeatures . _2 . _Just . _studyDegreeName . _Just
                                                   <> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow
                                         )
                              <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesSemester)
                              <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesType)
                        | otherwise -> Right <$> do
                            feats <- lift . E.select . E.from $ \(feat `E.InnerJoin` terms `E.InnerJoin` degree) -> do
                              E.on $ degree E.^. StudyDegreeId E.==. feat E.^. StudyFeaturesDegree
                              E.on $ terms E.^. StudyTermsId E.==. feat E.^. StudyFeaturesField
                              let registered = E.exists . E.from $ \participant ->
                                    E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
                                         E.&&. participant E.^. CourseParticipantUser E.==. E.val uid
                                         E.&&. participant E.^. CourseParticipantField E.==. E.just (feat E.^. StudyFeaturesId)
                              E.where_ $ registered
                                   E.||. feat E.^. StudyFeaturesValid
                              E.where_ $ feat E.^. StudyFeaturesUser E.==. E.val uid
                              return (terms, degree, feat)
                            return . Set.fromList . flip map feats $ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) ->
                              UserTableCsvStudyFeature
                                { csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName
                                , csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
                                , csvUserSemester = studyFeaturesSemester
                                , csvUserType = studyFeaturesType
                                }
                  <*> view _userTableRegistration
                  <*> userNote
                  <*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials)
            , dbtCsvName = unpack csvName
            , dbtCsvNoExportData = Nothing
            , dbtCsvHeader = return . Vector.filter csvColumns' . flip (userTableCsvHeader showSex) tutorials . fromMaybe def
            }
          where
            userNote = runMaybeT $ do
              noteId <- MaybeT . preview $ _userTableNote . _Just
              CourseUserNote{..} <- lift . lift $ getJust noteId
              return courseUserNoteNote
        dbtCsvDecode = Nothing
    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)
  if | allocated -> do
         wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip
         fmap CourseUserDeregisterData <$> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (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
  (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]
    let colChoices  = mconcat $ catMaybes
          [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
          , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
          , guardOn showSex $ colUserSex'
          , pure $ colUserEmail
          , pure $ colUserMatriclenr
          , pure $ colUserDegreeShort
          , pure $ colUserField
          , pure $ colUserSemester
          , guardOn hasTutorials $ colUserTutorials tid ssh csh
          , pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
          , pure $ colUserComment tid ssh csh
          ]
        psValidator = def & defaultSortingByName
        acts = mconcat
          [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
          , singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData <$>
            apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
                  (fslI MsgCourseTutorial)
                  Nothing
          , if
              | mayRegister
                -> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
              | otherwise
                -> mempty
          ]
    numParticipants <- count [CourseParticipantCourse ==. cid]
    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 . getBy $ UniqueParticipant uid cid
          lift $ deregisterParticipant courseParticipantUser courseParticipantCourse
          case deregisterReason of
            Just reason
              | is _Just courseParticipantAllocated ->
                  lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
            _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
  let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
      headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
  siteLayout headingLong $ do
    setTitleI headingShort
    $(widgetFile "course-participants")