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

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

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

data UserAction = UserLdapSync | UserHijack
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
  deriving anyclass (Universe, Finite)

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


data AllUsersAction = AllUsersLdapSync
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
  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 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 MsgAuthModeSet) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
      , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
      , flip foldMap universeF $ \function ->
          sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
            schools <- liftHandler . runDB . 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 (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
          let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
           in listCell' getFunctions i18nCell
      , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
          { formCellAttrs    = []
          , formCellLens     = id
          , formCellContents = do
              cID <- encrypt uid
              mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
              myUid <- liftHandler maybeAuthId
              if
                | mayHijack
                , Just uid /= myUid
                  -> lift $ do
                       let
                         postprocess :: FormResult () -> FormResult (First UserAction, 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 UserAction, DBFormResult UserId Bool (DBRow (Entity User))) -> FormResult (UserAction, Set UserId)
      postprocess inp = do
        (First (Just act), usrMap) <- inp
        let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
        return (act, usrSet)

    over _1 postprocess <$> 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
            )
          , ( "ldap-sync"
            , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
            )
          ]
      , 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
            )
          , ( "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)
            )
          ]
      , 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` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthModeSet)
          , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
          , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
          ]
      , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
      , dbtParams    = DBParamsForm
        { dbParamsFormMethod = POST
        , dbParamsFormAction = Just $ SomeRoute UsersR
        , dbParamsFormAttrs  = []
        , dbParamsFormSubmit = FormSubmit
        , dbParamsFormAdditional
            = renderAForm FormStandard
                 $  (, mempty) . First . Just
                <$> areq (selectField $ optionsF [UserLdapSync]) (fslI MsgAction) Nothing
        , dbParamsFormEvaluate = liftHandler . runFormPost
        , dbParamsFormResult   = id
        , dbParamsFormIdent    = def
        }
      , dbtIdent     = "users" :: Text
      , dbtCsvEncode = noCsvEncode
      , dbtCsvDecode = Nothing
      , dbtExtraReps = []
      }

  formResult usersRes $ \case
    (_, usersSet)
      | Set.null usersSet -> do
          addMessageI Info MsgActionNoUsersSelected
          redirect UsersR
    (UserLdapSync, userSet) -> do
      runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid
      addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
      redirect UsersR
    (UserHijack, Set.minView -> Just (uid, _)) ->
      hijackUser uid >>= sendResponse
    _other -> error "Should not be possible"

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

  formResult allUsersRes $ \case
    AllUsersLdapSync -> do
      runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
      addMessageI Success MsgSynchroniseLdapAllUsersQueued
      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) []

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

  ret <- formResultMaybe hijackRes $ \() -> Just <$> hijackUser uid

  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]


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

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

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


  

getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
getAdminUserR = postAdminUserR
postAdminUserR uuid = do
    adminId <- requireAuthId
    uid <- decrypt uuid
    (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 = 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]
        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_ 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 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

        userSystemFunctionsAction newFuncs = do
          let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions
          if
            | not $ Set.null symmDiff -> runDBJobs $ do
                forM_ symmDiff $ \func -> 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 oldUserId = do
          res <- try . runDB . setSerializable $ assimilateUser uid oldUserId
          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
              redirect $ AdminUserR uuid
    ((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} ^{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   = $(i18nWidgetFile "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
      deleteCascade submissionId

    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
  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)
             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
    liftHandler . 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 <- 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 <- 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 }

    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