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 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.Legacy 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

import Foundation.Yesod.Auth (updateUserLanguage)


data ExamOfficeSettings
  = ExamOfficeSettings
    { eosettingsGetSynced :: Bool
    , eosettingsGetLabels :: Bool
    , eosettingsLabels    :: EOLabels
    }

type EOLabelData
  = ( ExamOfficeLabelName
    , MessageStatus        -- status
    , Int                  -- priority; also used for label ordering
    )
type EOLabels = Map (Either ExamOfficeLabelName ExamOfficeLabelId) EOLabelData

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
      , stgExamOfficeSettings   :: ExamOfficeSettings
      , stgSchools              :: Set SchoolId
      , stgNotificationSettings :: NotificationSettings
      , stgAllocationNotificationSettings :: Map AllocationId (Maybe Bool)
      }
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
    NTKFunctionary SchoolAllocation -> mr MsgNotificationTriggerKindAllocationAdmin
    where
      mr = renderMessage f ls

data AllocationNotificationState
  = AllocNotifyNewCourseDefault
  | AllocNotifyNewCourseForceOff
  | AllocNotifyNewCourseForceOn
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)
embedRenderMessage ''UniWorX ''AllocationNotificationState id
nullaryPathPiece ''AllocationNotificationState $ camelToPathPiece' 2


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)
        <*> examOfficeForm (stgExamOfficeSettings <$> template)
        <*  aformSection MsgFormNotifications
        <*> schoolsForm (stgSchools <$> template)
        <*> notificationForm (stgNotificationSettings <$> template)
        <*> allocationNotificationForm (stgAllocationNotificationSettings <$> 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 <- lift . lift $ hasReadAccessTo AdminR

  let
    sectionIsHidden :: NotificationTriggerKind -> DB Bool
    sectionIsHidden = \case
      _
        | isAdmin
          -> return False
      NTKAll
        -> return False
      NTKCourseParticipant
        | Just uid <- mbUid
          -> fmap not . E.selectExists . E.from $ \courseParticipant ->
               E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
                    E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
      NTKSubmissionUser
        | Just uid <- mbUid
          -> fmap not . E.selectExists . E.from $ \submissionUser ->
               E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
      NTKExamParticipant
        | Just uid <- mbUid
          -> fmap not . E.selectExists . E.from $ \examRegistration ->
               E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
      NTKCorrector
        | Just uid <- mbUid
          -> fmap not . E.selectExists . E.from $ \sheetCorrector ->
               E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
      NTKCourseLecturer
        | Just uid <- mbUid
          -> fmap not . E.selectExists . E.from $ \lecturer ->
               E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
      NTKAllocationStaff
        | Just uid <- mbUid
          -> fmap not . E.selectExists . E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do
               E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
               E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
               E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
      NTKAllocationParticipant
        | Just uid <- mbUid
          -> fmap not . E.selectExists . E.from $ \courseApplication ->
               E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
                    E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocation)
      NTKFunctionary f
        | Just uid <- mbUid
          -> fmap not . E.selectExists . E.from $ \userFunction ->
               E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
                    E.&&. userFunction E.^. UserFunctionFunction E.==. E.val f
      _ | Nothing <- mbUid -> return False -- Show everything for not-logged-in users (e.g. if they presented a token)

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

  let
    ntfs nt = fslI nt & case nt of
      NTAllocationNewCourse -> setTooltip MsgNotificationTriggerAllocationNewCourseTip
      _other -> id
    
    nsForm nt
      | maybe False ntHidden $ ntSection nt
      = pure $ notificationAllowed def nt
      | nt `elem` forcedTriggers
      = aforced checkBoxField (ntfs nt) (notificationAllowed def nt)
      | otherwise
      = apopt checkBoxField (ntfs 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
      NTSheetHint                      -> Just NTKCourseParticipant
      NTSheetSolution                  -> 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
      NTAllocationNewCourse            -> Just NTKAllocationParticipant
      NTExamOfficeExamResults          -> Just $ NTKFunctionary SchoolExamOffice
      NTExamOfficeExamResultsChanged   -> Just $ NTKFunctionary SchoolExamOffice
      NTCourseRegistered               -> Just NTKAll
      NTQualification                  -> Just NTKAll
      -- _other                        -> Nothing

    forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate]

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

getAllocationNotifications :: UserId -> DB (Map AllocationId (Maybe Bool))
getAllocationNotifications uid
  = fmap (fmap (fmap getAny) . unMergeMap) . getAp $ foldMap (Ap . fmap (MergeMap . fmap (fmap Any)))
      [ getBySettings
      , getByApplications
      , getByAllocationUser
      ]
  where
    getBySettings = toMap <$> selectList [ AllocationNotificationSettingUser ==. uid ] []
      where toMap settings = Map.fromList [ ( allocationNotificationSettingAllocation
                                            , Just $ not allocationNotificationSettingIsOptOut
                                            )
                                          | Entity _ AllocationNotificationSetting{..} <- settings
                                          ]
    getByApplications = toMap <$> selectList [ CourseApplicationAllocation !=. Nothing, CourseApplicationUser ==. uid ] []
      where toMap applications = Map.fromList [ (alloc, Nothing)
                                              | Entity _ CourseApplication{..} <- applications
                                              , alloc <- hoistMaybe courseApplicationAllocation
                                              ]
    getByAllocationUser = toMap <$> selectList [ AllocationUserUser ==. uid ] []
      where toMap allocsUser = Map.fromList [ (allocationUserAllocation, Nothing)
                                            | Entity _ AllocationUser{..} <- allocsUser
                                            ]

setAllocationNotifications :: forall m. MonadIO m => UserId -> Map AllocationId (Maybe Bool) -> SqlPersistT m ()
setAllocationNotifications allocationNotificationSettingUser allocs = do
  deleteWhere [ AllocationNotificationSettingUser ==. allocationNotificationSettingUser ]
  void . insertMany $ do
    (allocationNotificationSettingAllocation, settingSt) <- Map.toList allocs
    allocationNotificationSettingIsOptOut <- not <$> hoistMaybe settingSt
    return AllocationNotificationSetting{..}
  
allocationNotificationForm :: Maybe (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool))
allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . (fromNullable =<<)
  where
    allocationNotificationForm' :: NonNull (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool))
    allocationNotificationForm' (toNullable -> allocs) = funcForm' . flip imap allocs $ \allocId mPrev -> wFormToAForm $ do
      let _AllocNotify :: Iso' (Maybe Bool) AllocationNotificationState
          _AllocNotify = iso toNotify fromNotify
            where fromNotify = \case
                    AllocNotifyNewCourseDefault  -> Nothing
                    AllocNotifyNewCourseForceOn  -> Just True
                    AllocNotifyNewCourseForceOff -> Just False
                  toNotify = \case
                    Nothing    -> AllocNotifyNewCourseDefault
                    Just True  -> AllocNotifyNewCourseForceOn
                    Just False -> AllocNotifyNewCourseForceOff

      Allocation{..} <- liftHandler . runDB $ getJust allocId
      MsgRenderer mr <- getMsgRenderer
      let allocDesc = [st|#{mr (ShortTermIdentifier $ unTermKey allocationTerm)}, #{unSchoolKey allocationSchool}, #{allocationName}|]
      cID <- encrypt allocId :: _ CryptoUUIDAllocation

      fmap (review _AllocNotify) <$> wpopt (radioGroupField Nothing optionsFinite) (fsl allocDesc & addName [st|alloc-notify__#{toPathPiece cID}|]) (Just $ mPrev ^. _AllocNotify)
      where funcForm' forms = funcForm forms (fslI MsgFormAllocationNotifications & setTooltip MsgFormAllocationNotificationsTip) False


examOfficeForm :: Maybe ExamOfficeSettings -> AForm Handler ExamOfficeSettings
examOfficeForm template = wFormToAForm $ do
  (_uid, User{userExamOfficeGetSynced,userExamOfficeGetLabels}) <- requireAuthPair
  currentRoute <- fromMaybe (error "examOfficeForm called from 404-handler") <$> liftHandler getCurrentRoute
  mr <- getMessageRender

  let
    userExamOfficeLabels :: EOLabels
    userExamOfficeLabels = maybe mempty eosettingsLabels template

    eoLabelsForm :: AForm Handler EOLabels
    eoLabelsForm = wFormToAForm $ do
      let
        miAdd :: ListPosition
              -> Natural
              -> ListLength
              -> (Text -> Text)
              -> FieldView UniWorX
              -> Maybe
                 (Form (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId)
                        -> FormResult (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId)))
                 )
        miAdd _ _ _ nudge submitView = Just $ \csrf -> do
          (addRes, addView) <- mpreq textField (fslI MsgExamOfficeLabelName & addName (nudge "name")) Nothing
          let
            addRes' = addRes <&> \nLabel oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
              | Set.member (Left nLabel) . Set.fromList $ Map.elems oldData
              -> FormFailure [mr MsgExamOfficeLabelAlreadyExists]
              | otherwise
              -> FormSuccess $ Map.singleton kStart (Left nLabel)
          return (addRes', $(widgetFile "profile/exam-office-labels/add"))
        
        miCell :: ListPosition
               -> Either ExamOfficeLabelName ExamOfficeLabelId
               -> Maybe EOLabelData
               -> (Text -> Text)
               -> Form EOLabelData
        miCell _ eoLabel initRes nudge csrf = do
          labelIdent <- case eoLabel of
            Left lblName -> return lblName
            Right lblId -> do
              ExamOfficeLabel{examOfficeLabelName} <- liftHandler . runDB $ getJust lblId
              return examOfficeLabelName
          (statusRes, statusView) <- mreq (selectField optionsFinite) (fslI MsgExamOfficeLabelStatus & addName (nudge "status")) ((\(_,x,_) -> x) <$> initRes)
          (priorityRes, priorityView) <- mreq intField (fslI MsgExamOfficeLabelPriority & addName (nudge "priority")) (((\(_,_,x) -> x) <$> initRes) <|> Just 0)
          let
            res :: FormResult EOLabelData
            res = (,,) <$> FormSuccess labelIdent <*> statusRes <*> priorityRes
          return (res, $(widgetFile "profile/exam-office-labels/cell"))

        miDelete :: Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId)
                 -> ListPosition
                 -> MaybeT (MForm Handler) (Map ListPosition ListPosition)
        miDelete = miDeleteList

        miAddEmpty :: ListPosition
                   -> Natural
                   -> ListLength
                   -> Set ListPosition
        miAddEmpty _ _ _ = Set.empty

        miButtonAction :: forall p.
                          PathPiece p
                       => p
                       -> Maybe (SomeRoute UniWorX)
        miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag

        miLayout :: ListLength
                 -> Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, FormResult EOLabelData)
                 -> Map ListPosition Widget
                 -> Map ListPosition (FieldView UniWorX)
                 -> Map (Natural, ListPosition) Widget
                 -> Widget
        miLayout lLength _ cellWdgts delButtons addWdgets = $(widgetFile "profile/exam-office-labels/layout")

        miIdent :: Text
        miIdent = "exam-office-labels"

        filledData :: Maybe (Map ListPosition (Either ExamOfficeLabelName ExamOfficeLabelId, EOLabelData))
        filledData = Just . Map.fromList . zip [0..] $ Map.toList userExamOfficeLabels

      fmap (Map.fromList . Map.elems) <$> massInputW MassInput{..} (fslI MsgExamOfficeLabels & setTooltip MsgExamOfficeLabelsTip) False filledData

  userIsExamOffice <- liftHandler . hasReadAccessTo $ ExamOfficeR EOExamsR
  if userIsExamOffice
    then
      aFormToWForm $ ExamOfficeSettings
        <$  aformSection MsgFormExamOffice
        <*> apopt checkBoxField (fslI MsgExamOfficeGetSynced & setTooltip MsgExamOfficeGetSyncedTip) (eosettingsGetSynced <$> template)
        <*> apopt checkBoxField (fslI MsgExamOfficeGetLabels & setTooltip MsgExamOfficeGetLabelsTip) (eosettingsGetLabels <$> template)
        <*> eoLabelsForm
    else
      return . pure . fromMaybe (ExamOfficeSettings userExamOfficeGetSynced userExamOfficeGetLabels userExamOfficeLabels) $ template


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, userExamOfficeLabels) <- runDB $ do
    userSchools <- fmap (setOf $ folded . _Value) . 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
    userExamOfficeLabels <- selectList [ ExamOfficeLabelUser ==. uid ] []
    return (userSchools, userExamOfficeLabels)
  allocs <- runDB $ getAllocationNotifications uid
  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
        , stgExamOfficeSettings   = ExamOfficeSettings
                                    { eosettingsGetSynced = userExamOfficeGetSynced
                                    , eosettingsGetLabels = userExamOfficeGetLabels
                                    , eosettingsLabels    = flip foldMap userExamOfficeLabels $ \(Entity eolid ExamOfficeLabel{..}) -> Map.singleton (Right eolid) (examOfficeLabelName,examOfficeLabelStatus,examOfficeLabelPriority)
                                    }
        , stgAllocationNotificationSettings = allocs
        }
  ((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
        , UserExamOfficeGetSynced  =. (stgExamOfficeSettings & eosettingsGetSynced)
        , UserExamOfficeGetLabels  =. (stgExamOfficeSettings & eosettingsGetLabels)
        ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ]
      setAllocationNotifications uid stgAllocationNotificationSettings
      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
               ]
      let
        oldExamLabels = userExamOfficeLabels
        newExamLabels = stgExamOfficeSettings & eosettingsLabels
      forM_ oldExamLabels $ \(Entity eolid ExamOfficeLabel{..}) -> unless (Right eolid `Map.member` newExamLabels || Left examOfficeLabelName `Map.member` newExamLabels) $ do
        E.delete . E.from $ \examOfficeExternalExamLabel -> E.where_ $ examOfficeExternalExamLabel E.^. ExamOfficeExternalExamLabelLabel E.==. E.val eolid
        E.delete . E.from $ \examOfficeExamLabel         -> E.where_ $ examOfficeExamLabel         E.^. ExamOfficeExamLabelLabel         E.==. E.val eolid
        when (csvExportLabel userCsvOptions == Just examOfficeLabelName) $
          update uid [ UserCsvOptions =. userCsvOptions { csvExportLabel = Nothing } ]
        delete eolid
      forM_ (Map.toList newExamLabels) $ \(eoLabelIdent, (examOfficeLabelName, examOfficeLabelStatus, examOfficeLabelPriority)) -> case eoLabelIdent of
        Left _ -> void $ upsert ExamOfficeLabel{ examOfficeLabelUser=uid, .. }
          [ ExamOfficeLabelName     =. examOfficeLabelName
          , ExamOfficeLabelStatus   =. examOfficeLabelStatus
          , ExamOfficeLabelPriority =. examOfficeLabelPriority
          ]
        Right lblId -> update lblId
          [ ExamOfficeLabelName     =. examOfficeLabelName
          , ExamOfficeLabelStatus   =. examOfficeLabelStatus
          , ExamOfficeLabelPriority =. examOfficeLabelPriority
          ]
    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 $ do
    setTitleI MsgHeadingProfileData
    dataWidget

makeProfileData :: Entity User -> DB Widget
makeProfileData (Entity uid User{..}) = do
  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, ownTutorialTable, tutorialTable :: Widget
      examTable        = i18n MsgPersonalInfoExamAchievementsWip
      ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
      tutorialTable    = i18n MsgPersonalInfoTutorialsWip

  cID <- encrypt uid
  mCRoute <- getCurrentRoute
  showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)

  let profileRemarks = $(i18nWidgetFile "profile-remarks")
  return $(widgetFile "profileData")



-- | Table listing all courses that the given user is a lecturer for
mkOwnedCoursesTable :: UserId -> DB (Bool, Widget)
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 = dbtProjId <&> _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))

      dbtColonnade = mconcat
          [ sortable (Just "term") (i18nCell MsgTableTerm & 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 MsgTableCourseSchool) $
              schoolCell <$> view (_dbrOutput . _1)
                         <*> view (_dbrOutput . _2 )
          , sortable (Just "course") (i18nCell MsgTableCourse) $
              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
      dbtExtraReps = []
  in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}


-- | Table listing all courses that the given user is enrolled in
mkEnrolledCoursesTable :: UserId -> DB Widget
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
               E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
          return (course, participant E.^. CourseParticipantRegistration)
      , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
      , dbtProj      = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
      , dbtColonnade = mconcat
          [ sortable (Just "term") (i18nCell MsgTableTerm) $
              termCell   <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
          , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
              schoolCell <$> view _courseTerm
                         <*> view _courseSchool
          , sortable (Just "course") (i18nCell MsgTableCourse) $
              courseCell <$> view (_dbrOutput . _1 . _entityVal)
          , sortable (Just "time") (i18nCell MsgProfileRegistered) $ 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
      , dbtExtraReps = []
      }


-- | Table listing all submissions for the given user
mkSubmissionTable :: UserId -> DB Widget
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 (Just uid)
          return . E.max_ $ subEdit E.^. SubmissionEditTime

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

      dbtColonnade = mconcat
        [ sortable (Just "term") (i18nCell MsgTableTerm) $
            termCell    <$> view (_dbrOutput . _1 . _1)
        , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
            schoolCell  <$> view  _1
                        <*> view  _2
        , sortable (Just "course") (i18nCell MsgTableCourse) $
            courseCellCL <$> view (_dbrOutput . _1)
        , sortable (Just "sheet") (i18nCell MsgTableSheet) . magnify _dbrOutput $
            sheetCell <$> view _1
                      <*> view _2
        , sortable (toNothingS "submission") (i18nCell MsgTableSubmission) . 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
      dbtExtraReps = []
  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
                  dbtSorting  = dbtSorting'  uid
              in  dbTableWidget' validator DBTable{..}
--   in do dbtSQLQuery <- dbtSQLQuery'
--         dbtSorting  <- dbtSorting'
--         return $ dbTableWidget' validator $ DBTable {..}


-- | Table listing all submissions for the given user
mkSubmissionGroupTable :: UserId -> DB Widget
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)
      dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId

      dbtProj = dbtProjId
        <&> _dbrOutput . _1 %~ $(E.unValueN 3)

      dbtColonnade = mconcat
        [ sortable (Just "term") (i18nCell MsgTableTerm) $
            termCell    <$> view (_dbrOutput . _1 . _1)
        , sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
            schoolCell  <$> view _1
                        <*> view _2
        , sortable (Just "course") (i18nCell MsgTableCourse) $
            courseCellCL <$> view (_dbrOutput . _1)
        , sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
            cell . views _submissionGroupName toWidget
        ]

      validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course"]
      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 )
        ]
      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
      dbtExtraReps = []
  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
              in  dbTableWidget' validator DBTable{..}


mkCorrectionsTable :: UserId -> DB Widget
mkCorrectionsTable =
  let dbtIdent = "corrections" :: Text
      dbtStyle = def
      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 = dbtProjId
        <&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
        <&> _dbrOutput . _2 %~ E.unValue

      dbtColonnade = mconcat
        [ sortable (Just "term") (i18nCell MsgTableTerm) $
            termCellCL   <$> view (_dbrOutput . _1)
        , sortable (Just "school") (i18nCell MsgTableCourseSchool) $
            schoolCellCL <$> view (_dbrOutput . _1)
        , sortable (Just "course") (i18nCell MsgTableCourse) $
            courseCellCL <$> view (_dbrOutput . _1)
        , sortable (Just "sheet") (i18nCell MsgTableSheet) . magnify _dbrOutput $
            sheetCell    <$> view _1 <*> view _2
        , sortable (Just "cstate") (i18nCell MsgTableCorState) $
            correctorStateCell <$> view (_dbrOutput . _3 . _entityVal)
        , sortable (toNothing "cload")  (i18nCell MsgTableCorProportion) $
            correctorLoadCell  <$> view (_dbrOutput . _3 . _entityVal)
        , sortable (toNothing "assigned")  (i18nCell MsgTableCorProportion) $
            int64Cell <$> view (_dbrOutput . _4 . _1 . _Value)
        , sortable (toNothing "corrected")  (i18nCell MsgTableCorProportion) $
            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
      dbtExtraReps = []
  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 $ (,)
    <$> apopt checkBoxField (fslI MsgActiveAuthTagsSaveCookie & setTooltip MsgActiveAuthTagsSaveCookieTip) (Just False)
    <*> fmap 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 $ \(saveCookie, authTagActive) -> do
    when saveCookie $ if
      | authTagActive == def -> deleteRegisteredCookie  CookieActiveAuthTags
      | otherwise            -> setRegisteredCookieJson CookieActiveAuthTags $ authTagActive ^. _ReducedActiveAuthTags
    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}, allocs) <- runDB $ (,)
    <$> get404 uid
    <*> getAllocationNotifications uid

  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard $ (,)
    <$> notificationForm (Just userNotificationSettings)
    <*> allocationNotificationForm (Just allocs)
  mBearer <- askBearer
  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 bearer) | Just bearer <- pure mBearer ]) $ \(ns, ans) -> do
    lift . runDB $ do
      update uid [ UserNotificationSettings =. ns ]
      setAllocationNotifications uid ans
    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 <- requireCurrentBearerRestrictions

  case mDisplayEmail of
    Nothing -> invalidArgs ["Bearer token required"]
    Just displayEmail -> do
      ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedBearerPost 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

  userIsExamOffice <- hasReadAccessTo $ ExamOfficeR EOExamsR
  examOfficeLabels <- if not userIsExamOffice then return mempty else runDB . E.select . E.from $ \examOfficeLabel -> do
    E.where_ $ examOfficeLabel E.^. ExamOfficeLabelUser E.==. E.val uid
    E.orderBy [ E.asc (examOfficeLabel E.^. ExamOfficeLabelName) ]
    return $ examOfficeLabel E.^. ExamOfficeLabelName

  ((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $
    csvOptionsForm (Just userCsvOptions) (Set.fromList $ E.unValue <$> examOfficeLabels)

  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
