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

module Handler.Users where

import Import

import Jobs
-- import Data.Text
import Handler.Utils
import Handler.Utils.Tokens
import Handler.Utils.Users
import Handler.Utils.Invitations

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 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 Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))


hijackUserForm :: CryptoUUIDUser -> Form ()
hijackUserForm cID csrf = do
  (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
  (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing
  return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])

-- In case of refactoring, use this:
-- instance HasEntity (DBRow (Entity User)) User where
--    hasEntity = _dbrOutput
-- instance HasUser   (DBRow (Entity USer)) where
--    hasUser = _entityVal

getUsersR :: Handler Html
getUsersR = do
  let
    dbtColonnade = dbColonnade . mconcat $
      [ dbRow
      , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
          (AdminUserR <$> encrypt uid)
          (nameWidget userDisplayName userSurname)
      , sortable (Just "matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
          (AdminUserR <$> encrypt uid)
          (toWgt userMatrikelnummer)
--       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
--           (AdminUserR <$> encrypt uid)
--           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
      , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
      , flip foldMap universeF $ \function ->
          sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
            schools <- lift . 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 Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
          cID <- encrypt uid
          mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
          myUid <- liftHandlerT maybeAuthId
          when (mayHijack && Just uid /= myUid) $ do
            (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm cID
            wrapForm hijackView FormSettings
              { formMethod   = POST
              , formAction   = Just . SomeRoute $ AdminHijackUserR cID
              , formEncoding = hijackEnctype
              , formAttrs    = []
              , formSubmit   = FormNoSubmit
              , formAnchor   = Nothing :: Maybe Text
              }
      ]
    psValidator = def
      & defaultSorting [SortAscBy "name", SortAscBy "display-name"]

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

    dbTable psValidator DBTable
      { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
      , dbtRowKey = (E.^. UserId)
      , dbtColonnade
      , dbtProj      = return
      , dbtSorting   = Map.fromList
          [ ( "name"
            , SortColumn $ \user -> user E.^. UserSurname
            )
          , ( "display-name"
            , SortColumn $ \user -> user E.^. UserDisplayName
            )
          , ( "matriculation"
            , SortColumn $ \user -> user E.^. UserMatrikelnummer
            )
          , ( "auth-ldap"
            , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
            )
          ]
      , dbtFilter    = Map.fromList -- OverloadedLists does not work with the templates
          [ ( "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
            )
          , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
                 | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
                 | otherwise         -> E.any (\c -> user E.^. UserMatrikelnummer `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
            )
          ]
      , dbtFilterUI  = \mPrev -> mconcat
          [ prismAForm (singletonFilter "user-search")    mPrev $ aopt textField  (fslI MsgName)
          -- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt textField (fslI MsgMatrikelNr)
          , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt matriculationField  (fslI MsgMatrikelNr)
          , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` radioFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
          , prismAForm (singletonFilter "school" )        mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
          ]
      , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
      , dbtParams    = def
      , dbtIdent     = "users" :: Text
      , dbtCsvEncode = noCsvEncode
      , dbtCsvDecode = Nothing
      }

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

postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
postAdminHijackUserR cID = do
  uid <- decrypt cID
  ((hijackRes, _), _) <- runFormPost $ hijackUserForm cID

  ret <- formResultMaybe hijackRes $ \() -> Just <$> do
    User{userIdent} <- runDB $ get404 uid
    setCredsRedirect $ Creds "dummy" (CI.original userIdent) []

  maybe (redirect UsersR) return ret


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

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

instance Button UniWorX ButtonAuthMode where
  btnClasses _ = [BCIsButton]


getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
getAdminUserR = postAdminUserR
postAdminUserR uuid = do
    adminId <- requireAuthId
    uid <- decrypt uuid
    (user@User{..}, adminSchools, functions, schools) <- 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)

      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
             )
    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 = identifyForm FIDuserRights $ \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]
    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_ 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, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
                void . Auth.campusUser conf pool $ 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 userAuthentication
                  
                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 userAuthentication
                    queueDBJob $ JobSendPasswordReset uid

                  addMessageI Success MsgAuthPWHashConfigured
            redirect $ AdminUserR uuid
          BtnPasswordReset -> do
            queueJob' $ JobSendPasswordReset uid
            addMessageI Success MsgPasswordResetQueued
            redirect $ AdminUserR uuid
    ((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm
    ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm
    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
          }
    formResult rightsResult userRightsAction
    formResult authResult userAuthenticationAction
    let heading =
          [whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|]
    -- 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   = $(widgetFile "widgets/data-delete/data-delete")
      $(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))
    deleteCascade duid
    forM_ singleSubmissions $ \(E.Value submissionId) -> do
      deleteFileIds  <- map E.unValue <$> getSubmissionFiles submissionId
      deleteCascade submissionId
      deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files

    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.sub_select $ E.from $ \subUsers -> do
                E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
                    E.&&.  subUsers E.^. SubmissionUserUser E.!=. E.val duid
                return E.countRows
        E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
             E.&&. whereBuddies numBuddies
        return $ submission E.^. SubmissionId

    getSubmissionFiles :: SubmissionId ->  DB [E.Value (Key File)]
    getSubmissionFiles subId = E.select $ E.from $ \file -> do
      E.where_ $ E.exists $ E.from $ \submissionFile ->
          E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
              E.&&.  submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
      return $ file E.^. FileId

    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
  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 maybeCurrentTokenRestrictions
        unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
          invalidArgsI [MsgUnauthorizedPasswordResetToken]
        return False
    ]

  ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedJwtPost . 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)
             Nothing
      | otherwise
        -> return $ FormSuccess ()

    newResult <- do
      resA <- wreq passwordField (fslI MsgNewPassword) Nothing
      wreq (checkBool ((== resA) . FormSuccess) MsgPasswordRepeatInvalid passwordField) (fslI MsgNewPasswordRepeat) Nothing

    return . fmap encodeUtf8 $ currentResult *> newResult

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

  siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] $
    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, Typeable)
  data InvitationDBData UserFunction = InvDBDataUserFunction
    { invDBUserFunctionDeadline :: UTCTime
    }
    deriving (Eq, Ord, Read, Show, Generic, Typeable)
  data InvitationTokenData UserFunction = InvTokenDataUserFunction
    { invTokenUserFunctionSchool :: SchoolShorthand
    , invTokenUserFunctionFunction :: SchoolFunction
    }
    deriving (Eq, Ord, Read, Show, Generic, Typeable)

  _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 <- liftHandlerT 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 <- E.select . E.from $ \term -> do
        E.where_ $ term E.^. TermActive
        E.orderBy [E.desc $ term E.^. TermName]
        E.limit 1
        return $ term E.^. TermId
      return . SomeRoute $ case currentTerm of
        [E.Value 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 }

    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) (fslI MsgFunctionaryInviteField & 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