-- SPDX-FileCopyrightText: 2022-2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

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

module Handler.Users
  ( module Handler.Users
  ) where

import Import

import Jobs
-- import Data.Text
import Handler.Utils
import Handler.Utils.Users
import Handler.Utils.Invitations
import Handler.Utils.Avs
import Handler.Utils.Company

import qualified Auth.LDAP as Auth

import qualified Data.CaseInsensitive as CI

import qualified Data.Set as Set
import qualified Data.Map as Map

import qualified Database.Esqueleto.Legacy as E
-- import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E



import Handler.Profile (makeProfileData)

import qualified Yesod.Auth.Util.PasswordStore as PWStore

import qualified Data.ByteString.Base64 as Base64

import Data.Aeson hiding (Result(..))

-- import Handler.Users.Add as Handler.Users

-- import qualified Data.Conduit.List as C

import qualified Data.HashSet as HashSet

import Auth.Dummy (apDummy)


hijackUserForm :: Form ()
hijackUserForm = \csrf -> do
  (btnResult, btnView) <- mopt (buttonField BtnHijack) "" Nothing
  return (btnResult >>= guard . is _Just, mconcat [toWidget csrf, fvWidget btnView])

instance HasEntity (DBRow (Entity User)) User where
   hasEntity = _dbrOutput
instance HasUser   (DBRow (Entity User)) where
   hasUser = _dbrOutput . _entityVal

data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserRemoveClients
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

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

data UserActionData = UserAvsSyncData
                    | UserLdapSyncData
                    | UserHijack
                    | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
                    | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
                    | UserRemoveSupervisorData
                    | UserRemoveClientsData

  deriving (Eq, Ord, Read, Show, Generic)

isNotSetSupervisor :: UserActionData -> Bool
isNotSetSupervisor UserSetSupervisorData{} = False
isNotSetSupervisor _ = True

isActionSupervisor :: UserActionData -> Bool
isActionSupervisor UserAddSupervisorData{} = True
isActionSupervisor UserSetSupervisorData{} = True
isActionSupervisor _ = False


data AllUsersAction = AllUsersLdapSync | AllUsersAvsSync
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

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

instance Button UniWorX AllUsersAction where
  btnClasses _ = [BCIsButton, BCPrimary]

getUsersR, postUsersR :: Handler Html
getUsersR = postUsersR
postUsersR = do
  MsgRenderer mr <- getMsgRenderer
  let
    dbtColonnade = mconcat
      [ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
      , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
          (AdminUserR <$> encrypt uid)
          (nameWidget userDisplayName userSurname)
      , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr
      , sortable (Just "user-company") (i18nCell MsgTableCompanies)   $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ liftHandler $ runDB $ -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
          maybeMonoid <$> wgtCompanies False uid
      -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- redundant
      --     (AdminUserR <$> encrypt uid)
      --     (toWgt userCompanyPersonalNumber)
      , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyPersonalNumber
      , sortable (Just "company-department") (i18nCell MsgCompanyDepartment)  $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment
--       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
--           (AdminUserR <$> encrypt uid)
--           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
      , sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
            supervisors' <- liftHandler . runDBRead . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
              E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
              E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
              E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
              return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
            let supervisors = intersperse (text2widget ", ") $
                  (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
                icnReroute = text2widget " " <> toWgt (icon IconReroute)
            pure $ mconcat supervisors
      , sortable (Just "last-login") (i18nCell MsgLastLogin)  $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
      , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
      , colUserEmail
      , colUserLetterEmailPin
      , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
      , flip foldMap universeF $ \function ->
          sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
            schools <- liftHandler . runDBRead . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
              E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
              E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
                   E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
              E.orderBy [E.asc $ school E.^. SchoolShorthand]
              return $ school E.^. SchoolShorthand
            return [whamlet|
              $newline never
              <ul .list--inline .list--comma-separated>
                $forall (E.Value sh) <- schools
                  <li>#{sh}
              |]
      , sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDBRead $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
           in listCell' getFunctions i18nCell
      , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
          { formCellAttrs    = []
          , formCellLens     = id
          , formCellContents = do
              cID <- encrypt uid
              mayHijack <- lift . lift $ (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
              myUid <- liftHandler maybeAuthId
              if
                | mayHijack
                , Just uid /= myUid
                  -> lift $ do
                       let
                         postprocess :: FormResult () -> FormResult (First UserActionData, DBFormResult UserId Bool (DBRow (Entity User)))
                         postprocess (FormSuccess ())   = FormSuccess (First $ Just UserHijack, DBFormResult $ Map.singleton uid (inp, const True))
                         postprocess  FormMissing       = FormSuccess mempty
                         postprocess (FormFailure errs) = FormFailure errs

                       over _1 postprocess <$> hijackUserForm mempty
                | otherwise
                  -> return mempty
          }
      ]
    psValidator = def
      & defaultSorting [SortAscBy "name", SortAscBy "display-name"]

  (usersRes, userList) <- runDB $ do
    schoolOptions <- map (CI.original . schoolName . entityVal &&& CI.original . unSchoolKey . entityKey)
      <$> selectList [] [Asc SchoolName]

    let
      postprocess :: FormResult (First UserActionData, DBFormResult UserId Bool (DBRow (Entity User))) -> FormResult (UserActionData, Set UserId)
      postprocess inp = do
        (First (Just act), usrMap) <- inp
        let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
        return (act, usrSet)

      superReasons :: HandlerFor UniWorX (OptionList Text)
      superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
        fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do
          usrc <- Ex.from $ Ex.table @UserSupervisor
          E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
          Ex.limit 9
          return $ usrc E.^. UserSupervisorReason
      acts :: Map UserAction (AForm Handler UserActionData)
      acts = mconcat
        [ singletonMap UserLdapSync      $ pure UserLdapSyncData
        , singletonMap UserAvsSync       $ pure UserAvsSyncData
        , singletonMap UserAddSupervisor $ UserAddSupervisorData
            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor       & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)     Nothing
            <*> apopt  boolField'                     (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)                (Just False)
            <*> aopt  (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
        , singletonMap UserSetSupervisor $ UserSetSupervisorData
            <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor       & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)     Nothing
            <*> apopt  boolField'                     (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)                (Just False)
            <*> aopt  (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
        , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
        , singletonMap UserRemoveClients $ pure UserRemoveClientsData
        ]

    over _1 postprocess <$> dbTable psValidator DBTable
      { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
      , dbtRowKey = (E.^. UserId)
      , dbtColonnade
      , dbtProj      = dbtProjId
      , dbtSorting   = Map.fromList $
          [ ( SortingKey $ CI.mk $ toPathPiece function
            , SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do
                E.where_ $ uf E.^. UserFunctionUser     E.==. user E.^. UserId
                    E.&&.  uf E.^. UserFunctionFunction E.==. E.val function
                return (uf E.^. UserFunctionSchool)
            ) | function <- universeF
          ] ++
          [ sortUserEmail id
          , sortUserLetterEmailPin id
          , ( "name"
            , SortColumn (E.^. UserSurname)
            )
          , ( "display-name"
            , SortColumn (E.^. UserDisplayName)
            )
           , ( "matriculation"
            , SortColumn $ \user -> user E.^. UserMatrikelnummer
            )
          , ( "personal-number"
            , SortColumn $ \user -> user E.^. UserCompanyPersonalNumber
            )
          , ( "company-department"
            , SortColumn $ \user -> user E.^. UserCompanyDepartment
            )
          , ( "auth-ldap"
            , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
            )
          , ( "last-login"
            , SortColumn $ \user -> user E.^. UserLastAuthentication
            )
          , ( "ldap-sync"
            , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
            )
          , ( "user-company"
            , SortColumn $ \user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
                E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                E.where_ $ usrComp E.^. UserCompanyUser E.==. user E.^. UserId
                E.orderBy [E.asc (comp E.^. CompanyName)]
                return (comp E.^. CompanyName)
            )
          , ( "user-supervisor"
            , SortColumn $ \user -> E.subSelect $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
                E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
                E.where_ $ spvr E.^. UserSupervisorUser E.==. user E.^. UserId
                E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
                return (usrSpvr E.^. UserDisplayName)
            )
          , ( "system-function"
            , SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do
                E.where_ $ usf E.^. UserSystemFunctionUser     E.==. user E.^. UserId
                return   $ usf E.^. UserSystemFunctionFunction
            )
          ]
      , dbtFilter    = Map.fromList -- OverloadedLists does not work with the templates
          [ fltrUserNameEmail id
          -- , ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
          --     if Set.null criteria then E.true else -- TODO: why is this condition not needed?
          --         -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text)
          --         E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria
          --   )
          -- , ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
          --     Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
          --     Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
          --   )
          -- , ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
          --     Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
          --     Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
          --             E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
          --   )
          , ( "personal-number"   , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber))
          , ( "matriculation"     , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches
          , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if                        -- exact filter on table UserAvs
                 | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
                 | otherwise         -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria
            )
          , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if
                | Just crit <- getLast criterion
                  -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit
                | otherwise
                  -> E.true
            )
          , ( "school", FilterColumn $ \user criterion -> if
                | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise          -> let schools = E.valList (Set.toList criterion) in
                    E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId
                                                       E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools
            )
          , ( "ldap-sync", FilterColumn $ \user criteria -> if
                | Just criteria' <- fromNullable criteria
                  -> let minTime = minimum (criteria' :: NonNull (Set UTCTime))
                      in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
                | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
            )
          , ( "avs-sync", FilterColumn . E.mkExistsFilter $ \user criterion ->
                E.from $ \usrAvs -> do
                  let minTime = (E.val criterion :: E.SqlExpr (E.Value UTCTime))
                  E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
                      E.&&.  usrAvs E.^. UserAvsLastSynch E.<=. minTime
            )
          , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
                E.from $ \(usrComp `E.InnerJoin` comp) -> do
                  let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
                                  (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
                      testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
                      testcrit = maybe testname testnumber $ readMay $ CI.original criterion
                  E.on $     usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
                  E.where_ $ usrComp E.^. UserCompanyUser    E.==. user E.^. UserId E.&&. testcrit
            )
          , ( "user-supervisor", FilterColumn $ \user criteria -> if
                | Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool)
                | otherwise ->
                    E.exists . E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
                      E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
                      E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId)
                        E.&&.  E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
            )
          -- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter
          --     E.from $ \usrAvs -> -- do
          --       E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
          --           E.&&.  ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
          --                 (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
          --   )
          , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
                Last (Just True)   -> E.exists    . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
                Last (Just False)  -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
                _                  -> E.val True :: E.SqlExpr (E.Value Bool)
            )
          ]
      , dbtFilterUI  = \mPrev -> mconcat
          [ fltrUserNameEmailHdrUI MsgName mPrev
          -- , prismAForm (singletonFilter "user-search")        mPrev $ aopt textField (fslI MsgName)
          -- , prismAForm (singletonFilter "user-ident")         mPrev $ aopt textField (fslI MsgAdminUserIdent)
          -- , prismAForm (singletonFilter "user-email")         mPrev $ aopt textField (fslI MsgAdminUserEmail)
          , prismAForm (singletonFilter "personal-number" )   mPrev $ aopt textField (fslI MsgCompanyPersonalNumberFraport & setTooltip MsgTableFilterCommaPlusShort)
          , prismAForm (singletonFilter "matriculation")      mPrev $ aopt matriculationField  (fslI MsgTableMatrikelNr    & setTooltip MsgTableFilterCommaPlusShort) -- contains filter on UserMatrikelnummer
          -- , prismAForm (singletonFilter "avs-number" )        mPrev $ aopt textField (fslI MsgAvsPersonNo               & setTooltip MsgTableFilterCommaPlusShort) -- exact filter on table UserAvs
          , prismAForm (singletonFilter "company-department") mPrev $ aopt textField (fslI MsgCompanyDepartment)
          , prismAForm (singletonFilter "user-company")       mPrev $ aopt textField (fslI MsgTableCompany)
          , prismAForm (singletonFilter "user-supervisor")    mPrev $ aopt textField (fslI MsgTableSupervisor)
          , prismAForm (singletonFilter "school")             mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
          , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
          , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
          , prismAForm (singletonFilter "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
          , prismAForm (singletonFilter "avs-sync"      . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLastAvsSyncedBefore)
          ]
      , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
      , dbtParams    = DBParamsForm
        { dbParamsFormMethod = POST
        , dbParamsFormAction = Nothing -- Just $ SomeRoute (UsersR, [("users-user-company","fraport")])
        , dbParamsFormAttrs  = []
        , dbParamsFormSubmit = FormSubmit
        , dbParamsFormAdditional
            = renderAForm FormStandard
                 $  (, mempty) . First . Just
                <$> multiActionA acts (fslI MsgTableAction) Nothing
        , dbParamsFormEvaluate = liftHandler . runFormPost
        , dbParamsFormResult   = id
        , dbParamsFormIdent    = def
        }
      , dbtIdent     = "users" :: Text
      , dbtCsvEncode = noCsvEncode
      , dbtCsvDecode = Nothing
      , dbtExtraReps = []
      }

  --   $logInfoS "UsersFormResult" $ tshow usersRes
  formResult usersRes $ \case
    (act, usersSet)
      | Set.null usersSet && isNotSetSupervisor act ->
          addMessageI Info MsgActionNoUsersSelected
    (UserLdapSyncData, userSet) -> do
      forM_ userSet $ \uid -> void . queueJob $ JobSynchroniseLdapUser uid
      addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
      redirectKeepGetParams UsersR
    (UserAvsSyncData, userSet) -> do
      n <- runDB $ queueAvsUpdateByUID userSet Nothing
      addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n
      redirectKeepGetParams UsersR
    (UserHijack, Set.lookupMin -> Just uid) ->
      hijackUser uid >>= sendResponse
    (UserRemoveSupervisorData, userSet) -> do
      runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
      addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
      redirectKeepGetParams UsersR
    (UserRemoveClientsData, userSet) -> do
      runDB $ deleteWhere [UserSupervisorSupervisor <-. Set.toList userSet]
      addMessageI Success $ MsgUsersRemoveClients $ Set.size userSet
      redirectKeepGetParams UsersR
    (act, usersSet)
      | isActionSupervisor act -> do
        avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act
        let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
            users = Set.toList usersSet
            nrSuperNotFound = length supersNotFound
        runDB $ do
          unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users]
          putMany [UserSupervisor s u r Nothing (getActionSupervisorReason act)
                  | let r = getActionRerouteNotifications act
                  , (_, Just s) <- supersFound
                  , u <- users
                  ]
        if nrSuperNotFound > 0
          then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound
          else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound)
        redirectKeepGetParams UsersR
    _other -> addMessageI Error MsgInvalidFormAction

  ((allUsersRes, allUsersWgt'), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm

  formResult allUsersRes $ \case
    AllUsersLdapSync -> do
      -- runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) -- to slow to execute directly
      queueJob' JobSynchroniseLdapAll
      addMessageI Success MsgSynchroniseLdapAllUsersQueued
      redirect UsersR
    AllUsersAvsSync -> do
      now <- liftIO getCurrentTime
      let nowaday = utctDay now
      n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser
        ( do
            usr <- Ex.from $ Ex.table @User
            return (AvsSync
                Ex.<#  (usr Ex.^. UserId)
                Ex.<&> E.val now
                -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
                Ex.<&> E.justVal nowaday
              )
        ) (\current excluded ->
            [ AvsSyncCreationTime E.=. E.least    (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
            , AvsSyncPause        E.=. E.greatest (current E.^. AvsSyncPause)        (excluded E.^. AvsSyncPause)
            ]
        )
      void $ queueJob JobSynchroniseAvsQueue
      addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n
      redirect UsersR

  let allUsersWgt = wrapForm allUsersWgt' def
        { formSubmit = FormNoSubmit
        , formAction = Just $ SomeRoute UsersR
        , formEncoding = allUsersEnctype
        }

  defaultLayout $ do
    setTitleI MsgUserListTitle
    $(widgetFile "users")

hijackUser :: UserId -> Handler TypedContent
hijackUser uid = do
  User{userIdent} <- runDB $ get404 uid
  setCredsRedirect $ Creds apDummy (CI.original userIdent) []

getAdminHijackUserR :: CryptoUUIDUser -> Handler Html
getAdminHijackUserR cID = do
  (hijackWgt, hijackEnctype) <- generateFormPost hijackUserForm
  let hjForm = wrapForm hijackWgt def{ formSubmit = FormNoSubmit, formEncoding = hijackEnctype, formAction = Just . SomeRoute $ AdminHijackUserR cID }
  uid :: UserId <- decrypt cID
  usr <- runDB $ get404 uid
  siteLayoutMsg MsgUserHijack $ do
    setTitleI MsgUserHijack
    [whamlet|
      ^{userWidget usr}
      ^{hjForm}
    |]

postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
postAdminHijackUserR cID = do
  ((hijackRes, _), _) <- runFormPost hijackUserForm
  $logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes
  uid <- decrypt cID
  ret <- formResultMaybe hijackRes $ \() -> Just <$> hijackUser uid
  maybe (redirect UsersR) return ret


data ButtonAuthMode = BtnAuthLDAP | BtnAuthPWHash | BtnPasswordReset
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
instance Universe ButtonAuthMode
instance Finite ButtonAuthMode

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

instance Button UniWorX ButtonAuthMode where
  btnClasses _ = [BCIsButton]


data UserAssimilateButton = BtnUserAssimilate
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

instance Button UniWorX UserAssimilateButton where
  btnClasses _ = [BCIsButton, BCPrimary]

nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''UserAssimilateButton id


data ThisUserAction = ThisUserLdapSync | ThisUserAvsSync --  ThisUserHijack would make sense, but this 'btn' should not always be visible
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

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

instance Button UniWorX ThisUserAction where
  btnClasses _ = [BCIsButton, BCPrimary]


getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
getAdminUserR = postAdminUserR
postAdminUserR uuid = do
    adminId <- requireAuthId
    uid <- decrypt uuid

    ((thisUserActRes, thisUserActWgt'), thisUserActEnctype) <- runFormPost . identifyForm FIDThisUserAction $ buttonForm
    formResult thisUserActRes $ \case
      ThisUserLdapSync -> do
        queueJob' $ JobSynchroniseLdapUser uid
        addMessageI Success $ MsgSynchroniseLdapUserQueued 1
        redirectKeepGetParams $ AdminUserR uuid
      ThisUserAvsSync -> do
        n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing
        addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n
        redirectKeepGetParams $ AdminUserR uuid
      -- ThisUserHijack -> do
      --   redirect $ AdminHijackUserR uuid
    let thisUserActWgt = wrapForm thisUserActWgt' def
          { formSubmit    = FormNoSubmit
          , formAction    = Just $ SomeRoute $ AdminUserR uuid
          , formEncoding  = thisUserActEnctype
          }

    (user@User{..}, adminSchools, functions, schools, systemFunctions) <- runDB $ do
      user <- get404 uid

      schools <- E.select . E.from $ \(school `E.LeftOuterJoin` userFunction) -> do
        E.on $ userFunction E.?. UserFunctionSchool E.==. E.just (school E.^. SchoolId)
         E.&&. userFunction E.?. UserFunctionUser   E.==. E.just (E.val uid)
        let isAdmin = E.exists . E.from $ \adminFunction ->
              E.where_ $ adminFunction E.^. UserFunctionUser     E.==. E.val adminId
                   E.&&. adminFunction E.^. UserFunctionSchool   E.==. school E.^. SchoolId
                   E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
        return (school, userFunction E.?. UserFunctionFunction, isAdmin)

      systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False] []
      let systemFunctions = (`Set.member` systemFunctionsF)

      return ( user
             , setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools
             , setOf (folded . folding (\x -> (,) <$> preview (_2 . _Value . _Just) x <*> preview (_1 . _entityKey) x)) schools
             , setOf (folded . _1) schools
             , systemFunctions
             )
    let allFunctions = Set.fromList universeF
        allSchools   = Set.mapMonotonic entityKey schools

    -- above data is needed for both form generation and result evaluation
    let userRightsForm :: Form (Set (SchoolFunction, SchoolId))
        userRightsForm csrf = do
          boxRights <- sequence . flip Map.fromSet (allFunctions `setProduct` allSchools) $ \(function, sid) -> if
            | sid `Set.member` adminSchools
              -> mpopt   checkBoxField "" . Just $ (function, sid) `Set.member` functions
            | otherwise
              -> mforced checkBoxField "" $ (function, sid) `Set.member` functions
          let result = Map.keysSet . Map.filter id <$> mapM (view _1) boxRights
          return (result, $(widgetFile "widgets/user-rights-form/user-rights-form"))
        userAuthenticationForm :: Form ButtonAuthMode
        userAuthenticationForm = buttonForm' $ if
          | userAuthentication == AuthLDAP -> [BtnAuthPWHash]
          | otherwise -> [BtnAuthLDAP, BtnPasswordReset]
        systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False
          where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func
    let userRightsAction changes = do
          let symDiff = (changes `Set.difference` functions) `Set.union` (functions `Set.difference` changes)
              updates = (allFunctions `setProduct` adminSchools) `Set.intersection` symDiff
          if
            | not $ Set.null updates -> runDBJobs $ do
                $logInfoS "user-rights-update" $ tshow updates
                forM_ (setOf (folded . _1) updates) $ \func ->
                  memcachedByInvalidate (AuthCacheSchoolFunctionList func) $ Proxy @(Set UserId)
                forM_ updates $ \(function, sid) -> do
                  $logDebugS "user-rights-update" [st|#{tshow (function, sid)}: #{tshow (Set.member (function, sid) functions)} → #{tshow (Set.member (function,sid) changes)}|]
                  if
                    | (function, sid) `Set.member` changes
                      -> void . insertUnique $ UserFunction uid sid function
                    | otherwise
                      -> deleteBy $ UniqueUserFunction uid sid function
                queueDBJob . JobQueueNotification . NotificationUserRightsUpdate uid $ Set.mapMonotonic (over _2 unSchoolKey) functions -- original rights to check for difference
                addMessageI Success MsgAccessRightsSaved
            | otherwise
              -> addMessageI Info MsgAccessRightsNotChanged
          redirect $ AdminUserR uuid

        userAuthenticationAction = \case
          BtnAuthLDAP -> do
            let
              campusHandler :: MonadPlus m => Auth.CampusUserException -> m a
              campusHandler _ = mzero
            campusResult <- runMaybeT . handle campusHandler $ do
                Just pool <- getsYesod $ view _appLdapPool
                void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) []
            case campusResult of
              Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
              _other
                | is _AuthLDAP userAuthentication
                  -> addMessageI Info MsgAuthLDAPAlreadyConfigured
              Just () -> do
                runDBJobs $ do
                  update uid [ UserAuthentication =. AuthLDAP ]
                  queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid

                addMessageI Success MsgAuthLDAPConfigured
            redirect $ AdminUserR uuid
          BtnAuthPWHash -> do
            if
              | is _AuthPWHash userAuthentication
                -> addMessageI Info MsgAuthPWHashAlreadyConfigured
              | otherwise
                -> do
                  runDBJobs $ do
                    update uid [ UserAuthentication =. AuthPWHash "" ]
                    queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
                    queueDBJob $ JobSendPasswordReset uid

                  addMessageI Success MsgAuthPWHashConfigured
            redirect $ AdminUserR uuid
          BtnPasswordReset -> do
            queueJob' $ JobSendPasswordReset uid
            addMessageI Success MsgPasswordResetQueued
            redirect $ AdminUserR uuid

        userSystemFunctionsAction newFuncs = do
          let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions
          if
            | not $ Set.null symmDiff -> runDBJobs $ do
                forM_ symmDiff $ \func -> do
                  memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
                  if | newFuncs func
                       -> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ]
                     | otherwise
                       -> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ]
                queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions
                addMessageI Success MsgUserSystemFunctionsSaved
            | otherwise
              -> addMessageI Info MsgUserSystemFunctionsNotChanged
          redirect $ AdminUserR uuid
    let assimilateForm' = renderAForm FormStandard $
          areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing
        assimilateAction newUserId = do
          res <- try . runDB . setSerializable $ assimilateUser newUserId uid
          case res of
            Left (err :: UserAssimilateException) ->
              addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right
                [whamlet|
                  <div .shown>
                    #{tshow err}
                |]
            Right warnings -> do
              unless (null warnings) $
                addMessageModal Warning (i18n MsgAssimilateUserHaveWarnings) $ Right
                  [whamlet|
                    $newline never
                    <ul>
                      $forall warning <- warnings
                        <li .shown>
                          #{tshow warning}
                  |]
              addMessageI Success MsgAssimilateUserSuccess
              newUuid <- encrypt newUserId
              redirect $ AdminUserR newUuid
    ((rightsResult, rightsFormWidget), rightsFormEnctype) <- runFormPost . identifyForm FIDUserRights $ userRightsForm
    ((authResult, authFormWidget), authFormEnctype) <- runFormPost . identifyForm FIDUserAuthentication $ userAuthenticationForm
    ((systemFunctionsResult, systemFunctionsWidget), systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'
    ((assimilateFormResult, assimilateFormWidget), assimilateFormEnctype) <- runFormPost $ identifyForm FIDUserAssimilate assimilateForm'
    let rightsForm = wrapForm rightsFormWidget def
          { formAction = Just . SomeRoute $ AdminUserR uuid
          , formEncoding = rightsFormEnctype
          }
        authForm = wrapForm authFormWidget def
          { formAction = Just . SomeRoute $ AdminUserR uuid
          , formEncoding = authFormEnctype
          , formSubmit = FormNoSubmit
          }
        systemFunctionsForm = wrapForm systemFunctionsWidget def
          { formAction = Just . SomeRoute $ AdminUserR uuid
          , formEncoding = systemFunctionsEnctype
          }
        assimilateForm = wrapForm' BtnUserAssimilate assimilateFormWidget def
          { formAction = Just . SomeRoute $ AdminUserR uuid
          , formEncoding = assimilateFormEnctype
          }
    formResult rightsResult userRightsAction
    formResult authResult userAuthenticationAction
    formResult systemFunctionsResult userSystemFunctionsAction
    formResult assimilateFormResult assimilateAction
    let heading =
          [whamlet|_{MsgAdminUserHeadingFor} ^{userEmailWidget user}|]
    -- Delete Button needed in data-delete
    (deleteWgt, deleteEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
    let deleteForm = wrapForm deleteWgt def
          { formAction   = Just $ SomeRoute $ AdminUserDeleteR uuid
          , formEncoding = deleteEnctype
          , formSubmit   = FormNoSubmit
          }
    userDataWidget <- runDB $ makeProfileData $ Entity uid user
    siteLayout heading $ do
      let _deleteWidget   = $(i18nWidgetFile "data-delete") -- TODO: update deletion text for FRADrive
      $(widgetFile "adminUser")


postAdminUserDeleteR :: CryptoUUIDUser -> Handler Html
postAdminUserDeleteR uuid = do
  uid <- decrypt uuid
  ((btnResult,_), _) <- runFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
  case btnResult of
    (FormSuccess BtnDelete) -> do
      User{..}  <- runDB $ get404 uid
      -- clearCreds False -- Logout-User
      ((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid
      -- addMessageIHamlet
      $(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
      -- addMessageI Success $ MsgDeleteUser deletedSubmissions
      -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
      defaultLayout
        $(widgetFile "deletedUser")

    -- (FormSuccess BtnAbort ) -> do
    --   addMessageI Info MsgAborted
    --   redirect ProfileDataR
    _other -> getAdminUserR uuid



deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration
deleteUser duid = do
    -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually
    -- We delete all files tied to submissions where the user is the lone submissionUser

    -- Do not deleteCascade submissions where duid is the corrector:
    updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing]

    groupSubmissions  <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>.  E.val (0::Int64))
    singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64))
    delete duid -- cascade is now defined in models files; therefor does not cascade at all currently (2021-06-27); not even SubmissionUser...
    forM_ singleSubmissions $ \(E.Value submissionId) -> do
      delete submissionId -- ditto

    deletedSubmissionGroups <- deleteSingleSubmissionGroups
    return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups)
  where
    selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
    selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
        E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
        let numBuddies = E.subSelectCount $ E.from $ \subUsers ->
                E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
                    E.&&.  subUsers E.^. SubmissionUserUser E.!=. E.val duid
        E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
             E.&&. whereBuddies numBuddies
        return $ submission E.^. SubmissionId

    deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
      E.where_ $ E.exists $ E.from $ \subGroupUser ->
          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
               E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
      E.where_ $ E.notExists $ E.from $ \subGroupUser ->
          E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
               E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid


getUserPasswordR, postUserPasswordR :: CryptoUUIDUser -> Handler Html
getUserPasswordR = postUserPasswordR
postUserPasswordR cID = do
  tUid <- decrypt cID
  usr@User{..} <- runDB $ get404 tUid
  PWHashConf{..} <- getsYesod $ view _appAuthPWHash
  isModal <- hasCustomHeader HeaderIsModal

  isAdmin <- hasWriteAccessTo $ AdminUserR cID

  requireCurrent <- maybeT (return True) $ asum
    [ False <$ guard (isn't _AuthPWHash userAuthentication)
    , False <$ guard isAdmin
    , do
        authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
        unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
          invalidArgsI [MsgUnauthorizedPasswordResetToken]
        return False
    ]

  ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
    currentResult <- if
      | AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
      , requireCurrent
        -> wreq
             (checkMap (bool (Left MsgCurrentPasswordInvalid) (Right ()) . flip (PWStore.verifyPasswordWith pwHashAlgorithm (2^)) pwHash . encodeUtf8) (const "") passwordField)
             (fslI MsgCurrentPassword & addAttr "autocomplete" "current-password")
             Nothing
      | otherwise
        -> return $ FormSuccess ()

    newResult <- do
      resA <- wreq passwordField (fslI MsgNewPassword & addAttr "autocomplete" "new-password") Nothing
      wreq (checkBool ((== resA) . FormSuccess) MsgPasswordRepeatInvalid passwordField) (fslI MsgNewPasswordRepeat & addAttr "autocomplete" "new-password") Nothing

    return . fmap encodeUtf8 $ currentResult *> newResult

  formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do
    newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength
    liftHandler . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ]
    tell . pure =<< messageI Success MsgPasswordChangedSuccess

  siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{userEmailWidget usr}|] $
    wrapForm passFormWidget def
      { formAction = Just . SomeRoute $ UserPasswordR cID
      , formEncoding = passEnctype
      , formAttrs = [ asyncSubmitAttr | isModal ]
      }


instance IsInvitableJunction UserFunction where
  type InvitationFor UserFunction = School
  data InvitableJunction UserFunction = JunctionUserFunction
    { jFunction :: SchoolFunction
    }
    deriving (Eq, Ord, Read, Show, Generic)
  data InvitationDBData UserFunction = InvDBDataUserFunction
    { invDBUserFunctionDeadline :: UTCTime
    }
    deriving (Eq, Ord, Read, Show, Generic)
  data InvitationTokenData UserFunction = InvTokenDataUserFunction
    { invTokenUserFunctionSchool :: SchoolShorthand
    , invTokenUserFunctionFunction :: SchoolFunction
    }
    deriving (Eq, Ord, Read, Show, Generic)

  _InvitableJunction = iso
    (\UserFunction{..} -> (userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction))
    (\(userFunctionUser, userFunctionSchool, JunctionUserFunction userFunctionFunction) -> UserFunction{..})

instance ToJSON (InvitableJunction UserFunction) where
  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1
                                        , fieldLabelModifier = camelToPathPiece' 1
                                        }
  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1
                                                , fieldLabelModifier = camelToPathPiece' 1
                                                }
instance FromJSON (InvitableJunction UserFunction) where
  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1
                                              , fieldLabelModifier = camelToPathPiece' 1
                                              }

instance ToJSON (InvitationDBData UserFunction) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData UserFunction) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }

instance ToJSON (InvitationTokenData UserFunction) where
  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData UserFunction) where
  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }

functionInvitationConfig :: InvitationConfig UserFunction
functionInvitationConfig = InvitationConfig{..}
  where
    invitationRoute _ _ = return AdminFunctionaryInviteR
    invitationResolveFor InvTokenDataUserFunction{..} = return $ SchoolKey invTokenUserFunctionSchool
    invitationSubject (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do
      MsgRenderer mr <- getMsgRenderer
      return . SomeMessage . MsgMailSubjectSchoolFunctionInvitation schoolName $ mr invTokenUserFunctionFunction
    invitationHeading (Entity _ School{..}) (_, InvTokenDataUserFunction{..}) = do
      MsgRenderer mr <- getMsgRenderer
      return . SomeMessage . MsgMailSchoolFunctionInviteHeading schoolName $ mr invTokenUserFunctionFunction
    invitationExplanation _ (_, InvTokenDataUserFunction{..}) = do
      MsgRenderer mr <- getMsgRenderer
      return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
    invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
      itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
      let itExpiresAt = Just $ Just invDBUserFunctionDeadline
          itAddAuth = Nothing
          itStartsAt = Nothing
      return InvitationTokenConfig{..}
    invitationRestriction _ _ = return Authorized
    invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure (JunctionUserFunction invTokenUserFunctionFunction, ())
    invitationInsertHook _ _ _ _ _ = id
    invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
      MsgRenderer mr <- getMsgRenderer
      return . SomeMessage . MsgSchoolFunctionInvitationAccepted schoolName $ mr userFunctionFunction
    invitationUltDest (Entity ssh _) _ = do
      currentTerm <- getCurrentTerm
      return . SomeRoute $ case currentTerm of
        Just tid -> TermSchoolCourseListR tid ssh
        _other   -> CourseListR


getAdminNewFunctionaryInviteR, postAdminNewFunctionaryInviteR :: Handler Html
getAdminNewFunctionaryInviteR = postAdminNewFunctionaryInviteR
postAdminNewFunctionaryInviteR = do
  uid <- requireAuthId
  userSchools <- runDB . E.select . E.from $ \userAdmin -> do
    E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val uid
         E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
    return $ userAdmin E.^. UserFunctionSchool

  ((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do
    now <- liftIO getCurrentTime
    let
      localNow = utcToLocalTime now
      beginToday = case localTimeToUTC (LocalTime (localDay localNow) midnight) of
        LTUUnique utc' _ -> utc'
        _other           -> UTCTime (utctDay now) 0
      defDeadline = beginToday{ utctDay = 14 `addDays` utctDay beginToday }

    mr <- getMessageRender

    function <- wreq (selectField optionsFinite) (fslI MsgFunctionaryInviteFunction) Nothing
    school   <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgFunctionaryInviteSchool) Nothing
    deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
    users    <- wreq (multiUserField False Nothing) (fslpI MsgFunctionaryInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing
    return $ (,,,) <$> function <*> school <*> deadline <*> users

  formResultModal invitesResult UsersR $ \(function, schoolId, deadline, users) -> do
    let (emails, uids) = partitionEithers $ Set.toList users
    lift . runDBJobs $ do
      forM_ uids $ \lecId ->
        void . insertUnique $ UserFunction lecId schoolId function

      sinkInvitationsF functionInvitationConfig [ (mail, schoolId, (InvDBDataUserFunction deadline, InvTokenDataUserFunction (unSchoolKey schoolId) function)) | mail <- emails ]

    unless (null emails) $
      tell . pure <=< messageI Success . MsgFunctionariesInvited $ length emails
    unless (null uids) $
      tell . pure <=< messageI Success . MsgFunctionariesAdded $ length uids

  siteLayoutMsg MsgFunctionaryInviteHeading $ do
    setTitleI MsgFunctionaryInviteHeading
    wrapForm invitesWgt def
      { formEncoding = invitesEncoding
      , formAction = Just $ SomeRoute AdminNewFunctionaryInviteR
      }

getAdminFunctionaryInviteR, postAdminFunctionaryInviteR :: Handler Html
getAdminFunctionaryInviteR = postAdminFunctionaryInviteR
postAdminFunctionaryInviteR = invitationR functionInvitationConfig
