module Handler.Profile
  ( getProfileR, postProfileR
  , getProfileDataR, makeProfileData
  , getAuthPredsR, postAuthPredsR
  , getUserNotificationR, postUserNotificationR
  , getSetDisplayEmailR, postSetDisplayEmailR
  , getCsvOptionsR, postCsvOptionsR
  , postLangR
  ) where

import Import

import Handler.Utils
import Handler.Utils.Profile
import Handler.Utils.Tokens

-- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
-- import           Database.Esqueleto      ((^.))
import qualified Data.Text as Text
import Data.List (inits)

import qualified Data.CaseInsensitive as CI

import Jobs


data SettingsForm = SettingsForm
      { stgDisplayName          :: UserDisplayName
      , stgDisplayEmail         :: UserEmail
      , stgMaxFavourites        :: Int
      , stgMaxFavouriteTerms    :: Int
      , stgTheme                :: Theme
      , stgDateTime             :: DateTimeFormat
      , stgDate                 :: DateTimeFormat
      , stgTime                 :: DateTimeFormat
      , stgDownloadFiles        :: Bool
      , stgWarningDays          :: NominalDiffTime
      , stgShowSex              :: Bool
      , stgSchools              :: Set SchoolId
      , stgNotificationSettings :: NotificationSettings
      }
makeLenses_ ''SettingsForm

data NotificationTriggerKind
  = NTKAll
  | NTKCourseParticipant
  | NTKSubmissionUser
  | NTKExamParticipant
  | NTKCorrector
  | NTKCourseLecturer
  | NTKAllocationStaff
  | NTKAllocationParticipant
  | NTKFunctionary SchoolFunction
  deriving (Eq, Ord, Generic, Typeable)
deriveFinite ''NotificationTriggerKind

instance RenderMessage UniWorX NotificationTriggerKind where
  renderMessage f ls = \case
    NTKAll -> mr MsgNotificationTriggerKindAll
    NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant
    NTKSubmissionUser -> mr MsgNotificationTriggerKindSubmissionUser
    NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant
    NTKCorrector -> mr MsgNotificationTriggerKindCorrector
    NTKCourseLecturer -> mr MsgNotificationTriggerKindCourseLecturer
    NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff
    NTKAllocationParticipant -> mr MsgNotificationTriggerKindAllocationParticipant
    NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
    NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer
    NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice
    NTKFunctionary SchoolEvaluation -> mr MsgNotificationTriggerKindEvaluation
    where
      mr = renderMessage f ls


makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template html = do
    MsgRenderer mr <- getMsgRenderer
    (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
        <$  aformSection MsgFormPersonalAppearance
        <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
        <*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
        <*  aformSection MsgFormCosmetics
        <*> areq (natFieldI MsgFavouritesNotNatural)
            (fslpI MsgFavourites (mr MsgFavouritesPlaceholder) & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
        <*> areq (natFieldI MsgFavouritesSemestersNotNatural)
            (fslpI MsgFavouriteSemesters (mr MsgFavouritesSemestersPlaceholder)) (stgMaxFavouriteTerms <$> template)
        <*> areq (selectField . return $ mkOptionList themeList)
            (fslI  MsgTheme) { fsId = Just "theme-select" } (stgTheme         <$> template)
        <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
        <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
        <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
        <*  aformSection MsgFormBehaviour
        <*> apopt checkBoxField (fslI MsgDownloadFiles
                                   & setTooltip MsgDownloadFilesTip
                                ) (stgDownloadFiles <$> template)
        <*> areq daysField (fslI MsgWarningDays
                & setTooltip MsgWarningDaysTip
              ) (stgWarningDays <$> template)
        <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template)
        <*  aformSection MsgFormNotifications
        <*> schoolsForm (stgSchools <$> template)
        <*> notificationForm (stgNotificationSettings <$> template)
    return (result, widget) -- no validation required here
  where
    themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF]

schoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandard schoolsForm' mempty
  where
    schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
    schoolsForm' = do
      allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]

      let
        schoolForm (Entity ssh School{schoolName})
          = fmap (bool Set.empty $ Set.singleton ssh) <$> wpopt checkBoxField (fsl $ CI.original schoolName) (Set.member ssh <$> template)

      fold <$> mapM schoolForm allSchools

    schoolsFormView :: (FormResult (Set SchoolId), Widget) -> MForm Handler (FormResult (Set SchoolId), [FieldView UniWorX])
    schoolsFormView (res, fvInput) = do
      mr <- getMessageRender
      let fvLabel = toHtml $ mr MsgUserSchools
          fvTooltip = Just . toHtml $ mr MsgUserSchoolsTip
          fvRequired = False
          fvErrors
            | FormFailure (err : _) <- res = Just $ toHtml err
            | otherwise = Nothing
      fvId <- newIdent
      return (res, pure FieldView{..})

notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
notificationForm template = wFormToAForm $ do
  mbUid <- liftHandler maybeAuthId
  isAdmin <- hasReadAccessTo AdminR

  let
    sectionIsHidden :: NotificationTriggerKind -> DB Bool
    sectionIsHidden nt
      | isAdmin
      = return False
      | Just uid <- mbUid
      , NTKFunctionary f <- nt
      = fmap not . E.selectExists . E.from $ \userFunction ->
          E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
               E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
      | Just uid <- mbUid
      , NTKCorrector <- nt
      = fmap not . E.selectExists . E.from $ \sheetCorrector ->
          E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
      | Just uid <- mbUid
      , NTKCourseParticipant <- nt
      = fmap not . E.selectExists . E.from $ \courseParticipant ->
          E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
      | Just uid <- mbUid
      , NTKSubmissionUser <- nt
      = fmap not . E.selectExists . E.from $ \submissionUser ->
          E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
      | Just uid <- mbUid
      , NTKExamParticipant <- nt
      = fmap not . E.selectExists . E.from $ \examRegistration ->
          E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
      | Just uid <- mbUid
      , NTKCourseLecturer <- nt
      = fmap not . E.selectExists . E.from $ \lecturer ->
          E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
      | otherwise
      = return False

  ntHidden <- liftHandler . runDB
            $ Set.fromList universeF
            & Map.fromSet sectionIsHidden
            & sequenceA
            & fmap (!)

  let
    nsForm nt
      | maybe False ntHidden $ ntSection nt
      = pure $ notificationAllowed def nt
      | nt `elem` forcedTriggers
      = aforced checkBoxField (fslI nt) (notificationAllowed def nt)
      | otherwise
      = apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)

    ntSection = \case
      NTSubmissionRatedGraded          -> Just NTKCourseParticipant
      NTSubmissionRated                -> Just NTKCourseParticipant
      NTSubmissionUserCreated          -> Just NTKCourseParticipant
      NTSubmissionUserDeleted          -> Just NTKSubmissionUser
      NTSubmissionEdited               -> Just NTKSubmissionUser
      NTSheetActive                    -> Just NTKCourseParticipant
      NTSheetSoonInactive              -> Just NTKCourseParticipant
      NTSheetInactive                  -> Just NTKCourseLecturer
      NTCorrectionsAssigned            -> Just NTKCorrector
      NTCorrectionsNotDistributed      -> Just NTKCourseLecturer
      NTUserRightsUpdate               -> Just NTKAll
      NTUserAuthModeUpdate             -> Just NTKAll
      NTExamRegistrationActive         -> Just NTKCourseParticipant
      NTExamRegistrationSoonInactive   -> Just NTKCourseParticipant
      NTExamDeregistrationSoonInactive -> Just NTKCourseParticipant
      NTExamResult                     -> Just NTKExamParticipant
      NTAllocationStaffRegister        -> Just $ NTKFunctionary SchoolLecturer
      NTAllocationAllocation           -> Just NTKAllocationStaff
      NTAllocationRegister             -> Just NTKAll
      NTAllocationOutdatedRatings      -> Just NTKAllocationStaff
      NTAllocationUnratedApplications  -> Just NTKAllocationStaff
      NTAllocationResults              -> Just NTKAllocationParticipant
      NTExamOfficeExamResults          -> Just $ NTKFunctionary SchoolExamOffice
      NTExamOfficeExamResultsChanged   -> Just $ NTKFunctionary SchoolExamOffice
      NTCourseRegistered               -> Just NTKAll
      -- _other                        -> Nothing

    forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate]

  aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False


validateSettings :: User -> FormValidator SettingsForm Handler ()
validateSettings User{..} = do
  userDisplayName' <- use _stgDisplayName
  
  guardValidation MsgUserDisplayNameInvalid $
    validDisplayName userTitle userFirstName userSurname userDisplayName'


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

nullaryPathPiece ''ButtonResetTokens $ camelToPathPiece' 1

embedRenderMessage ''UniWorX ''ButtonResetTokens id
instance Button UniWorX ButtonResetTokens where
  btnClasses BtnResetTokens = [BCIsButton, BCDanger]

data ProfileAnchor = ProfileSettings | ProfileResetTokens
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ProfileAnchor
instance Finite ProfileAnchor

nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1


getProfileR, postProfileR :: Handler Html
getProfileR = postProfileR
postProfileR = do
  (uid, user@User{..}) <- requireAuthPair
  userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do
    E.where_ . E.exists . E.from $ \userSchool ->
      E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
           E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
           E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
    return $ school E.^. SchoolId
  let settingsTemplate = Just SettingsForm
        { stgDisplayName          = userDisplayName
        , stgDisplayEmail         = userDisplayEmail
        , stgMaxFavourites        = userMaxFavourites
        , stgMaxFavouriteTerms    = userMaxFavouriteTerms
        , stgTheme                = userTheme
        , stgDateTime             = userDateTimeFormat
        , stgDate                 = userDateFormat
        , stgTime                 = userTimeFormat
        , stgDownloadFiles        = userDownloadFiles
        , stgSchools              = userSchools
        , stgNotificationSettings = userNotificationSettings
        , stgWarningDays          = userWarningDays
        , stgShowSex              = userShowSex
        }
  ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate

  formResult res $ \SettingsForm{..} -> do
    runDBJobs $ do
      update uid $
        [ UserDisplayName          =. stgDisplayName
        , UserMaxFavourites        =. stgMaxFavourites
        , UserMaxFavouriteTerms    =. stgMaxFavouriteTerms
        , UserTheme                =. stgTheme
        , UserDateTimeFormat       =. stgDateTime
        , UserDateFormat           =. stgDate
        , UserTimeFormat           =. stgTime
        , UserDownloadFiles        =. stgDownloadFiles
        , UserWarningDays          =. stgWarningDays
        , UserNotificationSettings =. stgNotificationSettings
        , UserShowSex              =. stgShowSex
        ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ]
      updateFavourites Nothing
      when (stgDisplayEmail /= userDisplayEmail) $ do
        queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
        addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
      let
        symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools)
      forM_ symDiff $ \ssh -> if
        | ssh `Set.member` stgSchools
          -> void $ upsert UserSchool
               { userSchoolSchool   = ssh
               , userSchoolUser     = uid
               , userSchoolIsOptOut = False
               }
               [ UserSchoolIsOptOut =. False
               ]
        | otherwise
          -> void $ upsert UserSchool
               { userSchoolSchool   = ssh
               , userSchoolUser     = uid
               , userSchoolIsOptOut = True
               }
               [ UserSchoolIsOptOut =. True
               ]
    addMessageI Success MsgSettingsUpdate
    redirect $ ProfileR :#: ProfileSettings

  ((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm

  formResult tokenRes $ \BtnResetTokens -> do
    now <- liftIO getCurrentTime
    runDB $ update uid [ UserTokensIssuedAfter =. Just now ]
    addMessageI Info MsgTokensResetSuccess
    redirect $ ProfileR :#: ProfileResetTokens

  tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter

  siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do
    setTitleI MsgProfileTitle
    let settingsForm =
          wrapForm formWidget FormSettings
            { formMethod = POST
            , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings
            , formEncoding = formEnctype
            , formAttrs = []
            , formSubmit = FormSubmit
            , formAnchor = Just ProfileSettings
            }
        tokenForm =
          wrapForm tokenFormWidget FormSettings
            { formMethod = POST
            , formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens
            , formEncoding = tokenEnctype
            , formAttrs = []
            , formSubmit = FormNoSubmit
            , formAnchor = Just ProfileResetTokens
            }
        tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation")
        displayNameRules = $(i18nWidgetFile "profile/displayNameRules")
    $(widgetFile "profile/profile")


getProfileDataR :: Handler Html
getProfileDataR = do
  userEnt <- requireAuth
  dataWidget <- runDB $ makeProfileData userEnt
  defaultLayout
    dataWidget

makeProfileData :: Entity User -> DB Widget
makeProfileData (Entity uid User{..}) = do
  -- MsgRenderer mr <- getMsgRenderer
  functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
  lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
      E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
      E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
      E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
      return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
  studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
      E.on $ studyfeat E.^. StudyFeaturesField    E.==. studyterms  E.^. StudyTermsId
      E.on $ studyfeat E.^. StudyFeaturesDegree   E.==. studydegree E.^. StudyDegreeId
      return  (studyfeat, studydegree, studyterms)
  --Tables
  (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
  enrolledCoursesTable <- mkEnrolledCoursesTable      uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
  submissionTable      <- mkSubmissionTable           uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
  submissionGroupTable <- mkSubmissionGroupTable      uid -- Tabelle mit allen Abgabegruppen
  correctionsTable     <- mkCorrectionsTable          uid -- Tabelle mit allen Korrektor-Aufgaben
  let examTable        = [whamlet|_{MsgPersonalInfoExamAchievementsWip}|]
  let ownTutorialTable = [whamlet|_{MsgPersonalInfoOwnTutorialsWip}|]
  let tutorialTable    = [whamlet|_{MsgPersonalInfoTutorialsWip}|]
  lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication
  let profileRemarks = $(i18nWidgetFile "profile-remarks")
  return $(widgetFile "profileData")



mkOwnedCoursesTable :: UserId -> DB (Bool, Widget)
-- Table listing all courses that the given user is a lecturer for
mkOwnedCoursesTable =
  let dbtIdent = "courseOwnership" :: Text
      dbtStyle = def

      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
               -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
      withType = id

      dbtSQLQuery' uid (course `E.InnerJoin` lecturer) = do
          E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
          E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
          return ( course E.^. CourseTerm
                 , course E.^. CourseSchool
                 , course E.^. CourseShorthand
                 )
      dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId
      dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))

      dbtColonnade = mconcat
          [ dbRow
          , sortable (Just "term") (i18nCell MsgTerm & cellAttrs .~ [("priority","0")]) $ do
              tid <- view (_dbrOutput . _1)
              return $ indicatorCell -- return True if one cell is produced here
                `mappend` termCell tid
          , sortable (Just "school") (i18nCell MsgCourseSchool) $
              schoolCell <$> view (_dbrOutput . _1)
                         <*> view (_dbrOutput . _2 )
          , sortable (Just "course") (i18nCell MsgCourse) $
              courseCellCL <$> view _dbrOutput
          ]

      validator = def & defaultSorting [ SortDescBy "term", SortAscBy "school", SortAscBy "course" ]
      dbtSorting = Map.fromList
          [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
          , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm     )
          , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool   )
          ]
      dbtFilter  = Map.fromList
          [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
          , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
          , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
          ]
      dbtFilterUI = mempty
      dbtParams = def
      dbtCsvEncode = noCsvEncode
      dbtCsvDecode = Nothing
  in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}



mkEnrolledCoursesTable :: UserId -> DB Widget
-- Table listing all courses that the given user is enrolled in
mkEnrolledCoursesTable =
  let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
               -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
      withType = id

      validator = def & defaultSorting [SortDescBy "time"]

  in \uid -> dbTableWidget' validator
    DBTable
      { dbtIdent     = "courseMembership" :: Text
      , dbtSQLQuery  = \(course `E.InnerJoin` participant) -> do
          E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
          E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
          return (course, participant E.^. CourseParticipantRegistration)
      , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
      , dbtProj      = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
      , dbtColonnade = mconcat
          [ dbRow
          , sortable (Just "term") (i18nCell MsgTerm) $
              termCell   <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
          , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
              schoolCell <$> view _courseTerm
                         <*> view _courseSchool
          , sortable (Just "course") (i18nCell MsgCourse) $
              courseCell <$> view (_dbrOutput . _1 . _entityVal)
          , sortable (Just "time") (i18nCell MsgRegistered) $ do
              regTime <- view $ _dbrOutput . _2
              return $ dateTimeCell regTime
            ]
      , dbtSorting   = Map.fromList
          [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName  )
          , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm  )
          , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool)
          , ( "time"  , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration)
          ]
      , dbtFilter    = Map.fromList
          [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName  )
          , ( "term"  , FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm  )
          , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
--          , ( "time"  , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
          ]
      , dbtFilterUI  = mempty
      , dbtStyle     = def
      , dbtParams = def
      , dbtCsvEncode = noCsvEncode
      , dbtCsvDecode = Nothing
      }



mkSubmissionTable :: UserId -> DB Widget
-- Table listing all submissions for the given user
mkSubmissionTable =
  let dbtIdent = "submissions" :: Text
      dbtStyle = def

      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
              ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
      withType = id

      dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) = do
        E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
        E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
        E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
        E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
        let crse = ( course E.^. CourseTerm
                   , course E.^. CourseSchool
                   , course E.^. CourseShorthand
                   )
        let sht  = sheet E.^. SheetName
        return (crse, sht, submission, lastSubEdit uid submission)
      dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId

      lastSubEdit uid submission = -- latest Edit-Time of this user for submission
        E.subSelectMaybe . E.from $ \subEdit -> do
          E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
              E.&&.  subEdit E.^. SubmissionEditUser E.==. E.val uid
          return . E.max_ $ subEdit E.^. SubmissionEditTime

      dbtProj x = return $ x
        & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
        & _dbrOutput . _2 %~ E.unValue
        & _dbrOutput . _4 %~ E.unValue

      dbtColonnade = mconcat
        [ dbRow
        , sortable (Just "term") (i18nCell MsgTerm) $
            termCell    <$> view (_dbrOutput . _1 . _1)
        , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
            schoolCell  <$> view  _1
                        <*> view  _2
        , sortable (Just "course") (i18nCell MsgCourse) $
            courseCellCL <$> view (_dbrOutput . _1)
        , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
            sheetCell <$> view _1
                      <*> view _2
        , sortable (toNothingS "submission") (i18nCell MsgSubmission) . magnify _dbrOutput $
            submissionCell  <$> view  _1
                            <*> view  _2
                            <*> view (_3 . _entityKey)
--           , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do
--               regTime <- view $ _dbrOutput . _4
--               return $ maybe mempty dateTimeCell regTime
        , sortable (Just "edit") (i18nCell MsgLastEditByUser) $
            maybe mempty dateTimeCell <$> view (_dbrOutput . _4)
        ]

      validator = def -- DUPLICATED CODE: Handler.Corrections
        & restrictFilter  (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
        & restrictSorting (\name _ -> name /= "corrector")
        & defaultSorting [SortDescBy "edit"]
      dbtSorting' uid = Map.fromList
        [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand)
        , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm     )
        , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseSchool   )
        , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet E.^. SheetName    )
        , ( "edit"  , SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) -> lastSubEdit uid submission )
        ]
      dbtFilter = Map.fromList
        [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
        , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
        , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
        ]
      dbtFilterUI = mempty
      dbtParams = def
      dbtCsvEncode = noCsvEncode
      dbtCsvDecode = Nothing
  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
                  dbtSorting  = dbtSorting'  uid
              in  dbTableWidget' validator DBTable{..}
--   in do dbtSQLQuery <- dbtSQLQuery'
--         dbtSorting  <- dbtSorting'
--         return $ dbTableWidget' validator $ DBTable {..}



mkSubmissionGroupTable :: UserId -> DB Widget
-- Table listing all submissions for the given user
mkSubmissionGroupTable =
  let dbtIdent = "subGroups" :: Text
      dbtStyle = def
      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
              ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
      withType = id

      dbtSQLQuery' uid (course `E.InnerJoin` sgroup `E.InnerJoin` sguser) = do
        E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
        E.on $ sgroup E.^. SubmissionGroupCourse              E.==. course E.^. CourseId
        E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
        let crse =  ( course E.^. CourseTerm
                    , course E.^. CourseSchool
                    , course E.^. CourseShorthand
                    )
        return (crse, sgroup, lastSGEdit sgroup)
      dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId

      lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
        E.subSelectMaybe . E.from $ \(user `E.InnerJoin` sgEdit) -> do
          E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser
          E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
          return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime

      dbtProj x = return $ x
        & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
        & _dbrOutput . _3 %~ E.unValue

      dbtColonnade = mconcat
        [ dbRow
        , sortable (Just "term") (i18nCell MsgTerm) $
            termCell    <$> view (_dbrOutput . _1 . _1)
        , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
            schoolCell  <$> view _1
                        <*> view _2
        , sortable (Just "course") (i18nCell MsgCourse) $
            courseCellCL <$> view (_dbrOutput . _1)
        , sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
            maybe mempty textCell <$> view _submissionGroupName
        , sortable (Just "edit") (i18nCell MsgLastEdit) $
            maybe mempty dateTimeCell <$> view (_dbrOutput . _3)
        ]

      validator = def -- DUPLICATED CODE: Handler.Corrections
        & restrictFilter  (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
        & restrictSorting (\name _ -> name /= "corrector")
        & defaultSorting [SortDescBy "edit"]
      dbtSorting = Map.fromList
        [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
        , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm     )
        , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool   )
        , ( "submissiongroup" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _) -> sgroup E.^. SubmissionGroupName )
        , ( "edit"  , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _ ) -> lastSGEdit sgroup)
        ]
      dbtFilter = Map.fromList
        [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
        , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
        , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
        ]
      dbtFilterUI = mempty
      dbtParams = def
      dbtCsvEncode = noCsvEncode
      dbtCsvDecode = Nothing
  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
              in  dbTableWidget' validator DBTable{..}



mkCorrectionsTable :: UserId -> DB Widget
-- Table listing sum of corrections made by the given user per sheet
mkCorrectionsTable =
  let dbtIdent = "corrections" :: Text
      dbtStyle = def
-- TODO Continue here
      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
              ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
      withType = id

      corrsAssigned uid sheet = E.subSelectCount . E.from $ \submission ->
          E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
              E.&&.  submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)

      corrsCorrected uid sheet = E.subSelectCount . E.from $ \submission ->
          E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
               E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
               E.&&. E.not_ (E.isNothing $ submission E.^. SubmissionRatingTime)

      dbtSQLQuery' uid (course `E.InnerJoin` sheet `E.InnerJoin` corrector) = do
        E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
        E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
        E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
        let crse =  ( course E.^. CourseTerm
                    , course E.^. CourseSchool
                    , course E.^. CourseShorthand
                    )
        return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
      dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId

      dbtProj x = return $ x
        & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
        & _dbrOutput . _2 %~ E.unValue

      dbtColonnade = mconcat
        [ dbRow
        , sortable (Just "term") (i18nCell MsgTerm) $
            termCellCL   <$> view (_dbrOutput . _1)
        , sortable (Just "school") (i18nCell MsgCourseSchool) $
            schoolCellCL <$> view (_dbrOutput . _1)
        , sortable (Just "course") (i18nCell MsgCourse) $
            courseCellCL <$> view (_dbrOutput . _1)
        , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
            sheetCell    <$> view _1 <*> view _2
        , sortable (Just "cstate") (i18nCell MsgCorState) $
            correctorStateCell <$> view (_dbrOutput . _3 . _entityVal)
        , sortable (toNothing "cload")  (i18nCell MsgCorProportion) $
            correctorLoadCell  <$> view (_dbrOutput . _3 . _entityVal)
        , sortable (toNothing "assigned")  (i18nCell MsgCorProportion) $
            int64Cell <$> view (_dbrOutput . _4 . _1 . _Value)
        , sortable (toNothing "corrected")  (i18nCell MsgCorProportion) $
            int64Cell <$> view (_dbrOutput . _4 . _2 . _Value)
        ]

      validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"]
      dbtSorting = Map.fromList
        [ ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse  E.^. CourseTerm     )
        , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse  E.^. CourseSchool   )
        , ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse  E.^. CourseShorthand)
        , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _) -> sheet E.^. SheetName      )
        , ( "cstate", SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs)    -> cs    E.^. SheetCorrectorState )
        ]
      dbtFilter = Map.fromList
        [ ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
        , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
        , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
        ]
      dbtFilterUI = mempty
      dbtParams = def
      dbtCsvEncode = noCsvEncode
      dbtCsvDecode = Nothing
  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
              in  dbTableWidget' validator DBTable{..}


getAuthPredsR, postAuthPredsR :: Handler Html
getAuthPredsR = postAuthPredsR
postAuthPredsR = do
  (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags

  let
    blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
    taForm authTag
      | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
      | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)

  ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
    $ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True

  mReferer <- runMaybeT $ do
    param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
    MaybeT . return $ fromPathPiece param

  let authActiveForm = wrapForm authActiveWidget' def
        { formAction = Just $ SomeRoute AuthPredsR
        , formEncoding = authActiveEnctype
        , formSubmit = FormDualSubmit
        }
      authActiveWidget'
        = [whamlet|
            $newline never
            $maybe referer <- mReferer
              <input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
            ^{authActiveWidget}
          |]

  formResult authActiveRes $ \authTagActive -> do
    setSessionJson SessionActiveAuthTags authTagActive
    modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive)
    addMessageI Success MsgAuthPredsActiveChanged
    redirect $ fromMaybe AuthPredsR mReferer

  siteLayoutMsg MsgAuthPredsActive $ do
    setTitleI MsgAuthPredsActive
    $(widgetFile "authpreds")


getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html
getUserNotificationR = postUserNotificationR
postUserNotificationR cID = do
  uid <- decrypt cID
  User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid

  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
  mJwt <- askJwt
  isModal <- hasCustomHeader HeaderIsModal
  let formWidget = wrapForm nsInnerWdgt def
        { formAction = Just . SomeRoute $ UserNotificationR cID
        , formEncoding = nsEnc
        , formAttrs = [ asyncSubmitAttr | isModal ]
        }

  formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
    lift . runDB $ update uid [ UserNotificationSettings =. ns ]
    tell . pure =<< messageI Success MsgNotificationSettingsUpdate

  siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
    setTitleI $ MsgNotificationSettingsHeading userDisplayName
    formWidget


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

nullaryPathPiece ''ButtonSetDisplayEmail $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonSetDisplayEmail id

instance Button UniWorX ButtonSetDisplayEmail where
  btnClasses _ = [BCIsButton]


getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html
getSetDisplayEmailR = postSetDisplayEmailR
postSetDisplayEmailR = do
  uid <- requireAuthId
  mDisplayEmail <- requireCurrentTokenRestrictions

  case mDisplayEmail of
    Nothing -> invalidArgs ["Bearer token required"]
    Just displayEmail -> do
      ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedJwtPost buttonForm
      let btnView' = wrapForm btnView def
            { formSubmit = FormNoSubmit
            , formAction = Just $ SomeRoute SetDisplayEmailR
            , formEncoding = btnEnc
            }

      formResult btnRes $ \case
        BtnSetDisplayEmail -> do
          runDB $
            update uid [UserDisplayEmail =. displayEmail]
          addMessageI Success MsgUserDisplayEmailChanged
          redirect ProfileR

      siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do
        setTitleI MsgTitleChangeUserDisplayEmail
        $(i18nWidgetFile "set-display-email")
  
getCsvOptionsR, postCsvOptionsR :: Handler Html
getCsvOptionsR = postCsvOptionsR
postCsvOptionsR = do
  Entity uid User{userCsvOptions} <- requireAuth

  ((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $
    csvOptionsForm (Just userCsvOptions)

  formResultModal optionsRes CsvOptionsR $ \opts -> do
    lift . runDB $ update uid [ UserCsvOptions =. opts ]
    tell . pure =<< messageI Success MsgCsvOptionsUpdated

  siteLayoutMsg MsgCsvOptions $ do
    setTitleI MsgCsvOptions

    isModal <- hasCustomHeader HeaderIsModal
    wrapForm optionsWgt' def
      { formAction = Just $ SomeRoute CsvOptionsR
      , formEncoding = optionsEnctype
      , formAttrs = [ asyncSubmitAttr | isModal ]
      }

postLangR :: Handler Void
postLangR = do
  requestedLang <- selectLanguage' appLanguages . hoistMaybe <$> lookupGlobalPostParam PostLanguage
  lang' <- runDB . updateUserLanguage $ Just requestedLang

  app <- getYesod
  let mr | Just lang'' <- lang' = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang''
         | otherwise = renderMessage app []
  addMessage Success . toHtml $ mr MsgLanguageChanged

  redirect . fromMaybe NewsR =<< lookupGlobalGetParam GetReferer