chore(users): remove ldap-specific columns in admin users page
This commit is contained in:
parent
899071e4d6
commit
ad937cda8c
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 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-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, 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
|
||||
|
||||
@ -11,14 +11,11 @@ module Handler.Users
|
||||
import Import
|
||||
|
||||
import Jobs
|
||||
-- import Data.Text
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Avs
|
||||
|
||||
import qualified Auth.LDAP as Auth
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Set as Set
|
||||
@ -35,8 +32,6 @@ 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
|
||||
@ -130,8 +125,8 @@ postUsersR = do
|
||||
icnReroute = text2widget " " <> toWgt (icon IconLetter)
|
||||
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
|
||||
, sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
|
||||
-- , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication -- TODO: reintroduce via ExternalAuth
|
||||
-- , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation -- TODO: reintroduce via ExternalAuth
|
||||
, flip foldMap universeF $ \function ->
|
||||
sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
|
||||
schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
|
||||
@ -226,15 +221,15 @@ postUsersR = do
|
||||
, ( "company-department"
|
||||
, SortColumn $ \user -> user E.^. UserCompanyDepartment
|
||||
)
|
||||
, ( "auth-ldap"
|
||||
, SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
|
||||
)
|
||||
-- , ( "auth-ldap"
|
||||
-- , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
|
||||
-- ) -- TODO: reintroduce via ExternalAuth
|
||||
, ( "last-login"
|
||||
, SortColumn $ \user -> user E.^. UserLastAuthentication
|
||||
)
|
||||
, ( "ldap-sync"
|
||||
, SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
|
||||
)
|
||||
-- , ( "ldap-sync"
|
||||
-- , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
|
||||
-- ) -- TODO: reintroduce via ExternalAuth
|
||||
, ( "user-company"
|
||||
, SortColumn $ \user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||
@ -276,24 +271,24 @@ postUsersR = do
|
||||
| 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
|
||||
)
|
||||
-- , ( "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
|
||||
-- ) -- TODO: reintroduce via ExternalAuth
|
||||
, ( "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)
|
||||
)
|
||||
-- , ( "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)
|
||||
-- ) -- TODO: reintroduce via ExternalAuth
|
||||
, ( "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`
|
||||
@ -335,8 +330,8 @@ postUsersR = do
|
||||
, 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 "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) -- TODO: reintroduce via ExternalAuth
|
||||
-- , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) -- TODO: reintroduce via ExternalAuth
|
||||
]
|
||||
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
, dbtParams = DBParamsForm
|
||||
@ -364,7 +359,7 @@ postUsersR = do
|
||||
| Set.null usersSet && isNotSetSupervisor act ->
|
||||
addMessageI Info MsgActionNoUsersSelected
|
||||
(UserLdapSyncData, userSet) -> do
|
||||
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseUserdbUser uid
|
||||
forM_ userSet $ queueJob' . JobSynchroniseUser
|
||||
addMessageI Success . MsgSynchroniseUserdbUserQueued $ Set.size userSet
|
||||
redirectKeepGetParams UsersR
|
||||
(UserAvsSyncData, userSet) -> do
|
||||
@ -400,7 +395,7 @@ postUsersR = do
|
||||
|
||||
formResult allUsersRes $ \case
|
||||
AllUsersLdapSync -> do
|
||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUserdbUser . entityKey)
|
||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUser . entityKey)
|
||||
addMessageI Success MsgSynchroniseUserdbAllUsersQueued
|
||||
redirect UsersR
|
||||
let allUsersWgt' = wrapForm allUsersWgt def
|
||||
@ -506,7 +501,7 @@ postAdminUserR uuid = do
|
||||
return (result, $(widgetFile "widgets/user-rights-form/user-rights-form"))
|
||||
userAuthenticationForm :: Form ButtonAuthMode
|
||||
userAuthenticationForm = buttonForm' $ if
|
||||
| userAuthentication == AuthLDAP -> [BtnAuthPWHash]
|
||||
| is _Nothing userPasswordHash -> [BtnAuthPWHash]
|
||||
| otherwise -> [BtnAuthLDAP, BtnPasswordReset]
|
||||
systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False
|
||||
where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func
|
||||
@ -532,33 +527,41 @@ postAdminUserR uuid = do
|
||||
redirect $ AdminUserR uuid
|
||||
|
||||
userAuthenticationAction = \case
|
||||
BtnAuthLDAP -> do -- TODO WIP
|
||||
let
|
||||
campusHandler :: MonadPlus m => Auth.CampusUserException -> m a
|
||||
campusHandler _ = mzero
|
||||
campusResult <- runMaybeT . handle campusHandler $ do
|
||||
Just pool <- getsYesod $ view _appLdapPool
|
||||
void . lift . Auth.ldapUser 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
|
||||
BtnAuthLDAP -> do -- TODO: Reformulate messages and constructors to "remove pw hash" or "external login only"
|
||||
-- let
|
||||
-- ldapHandler :: MonadPlus m => Auth.LdapUserException -> m a
|
||||
-- ldapHandler _ = mzero
|
||||
-- ldapResult <- runMaybeT . handle ldapHandler $ do
|
||||
-- Just pool <- getsYesod $ view _appLdapPool
|
||||
-- void . lift . Auth.ldapUser pool $ Creds Auth.apLdap (CI.original userIdent) []
|
||||
-- case ldapResult 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
|
||||
-- TODO: check current auth sources and warn if user cannot login using any source
|
||||
case userPasswordHash of
|
||||
Nothing -> addMessageI Error MsgAuthLDAPAlreadyConfigured
|
||||
Just _ -> do
|
||||
runDBJobs $ do
|
||||
update uid [ UserPasswordHash =. Nothing ]
|
||||
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
|
||||
addMessageI Success MsgAuthLDAPConfigured
|
||||
redirect $ AdminUserR uuid
|
||||
BtnAuthPWHash -> do
|
||||
if
|
||||
| is _AuthPWHash userAuthentication
|
||||
| is _Just userPasswordHash
|
||||
-> addMessageI Info MsgAuthPWHashAlreadyConfigured
|
||||
| otherwise
|
||||
-> do
|
||||
runDBJobs $ do
|
||||
update uid [ UserAuthentication =. AuthPWHash "" ]
|
||||
update uid [ UserPasswordHash =. Just "" ]
|
||||
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
|
||||
queueDBJob $ JobSendPasswordReset uid
|
||||
|
||||
@ -718,18 +721,18 @@ postUserPasswordR cID = do
|
||||
isAdmin <- hasWriteAccessTo $ AdminUserR cID
|
||||
|
||||
requireCurrent <- maybeT (return True) $ asum
|
||||
[ False <$ guard (isn't _AuthPWHash userAuthentication)
|
||||
[ False <$ guard (isn't _Just userPasswordHash)
|
||||
, False <$ guard isAdmin
|
||||
, do
|
||||
authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
|
||||
unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
|
||||
unless (authMode `constEq` computeUserAuthenticationDigest userPasswordHash) . lift $
|
||||
invalidArgsI [MsgUnauthorizedPasswordResetToken]
|
||||
return False
|
||||
]
|
||||
|
||||
((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
|
||||
currentResult <- if
|
||||
| AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
|
||||
| Just (encodeUtf8 -> pwHash) <- userPasswordHash
|
||||
, requireCurrent
|
||||
-> wreq
|
||||
(checkMap (bool (Left MsgCurrentPasswordInvalid) (Right ()) . flip (PWStore.verifyPasswordWith pwHashAlgorithm (2^)) pwHash . encodeUtf8) (const "") passwordField)
|
||||
@ -746,7 +749,7 @@ postUserPasswordR cID = do
|
||||
|
||||
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 ]
|
||||
liftHandler . runDB $ update tUid [ UserPasswordHash =. Just newHash ]
|
||||
tell . pure =<< messageI Success MsgPasswordChangedSuccess
|
||||
|
||||
siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{userEmailWidget usr}|] $
|
||||
|
||||
Reference in New Issue
Block a user