fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(users): remove ldap-specific columns in admin users page

Browse Source
This commit is contained in:
Sarah Vaupel 2024-02-21 07:12:29 +01:00
parent 899071e4d6
commit ad937cda8c
1 changed files with 56 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
src/Handler/Users.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -11,14 +11,11 @@ module Handler.Users
import Import import Import
import Jobs import Jobs
-- import Data.Text
import Handler.Utils import Handler.Utils
import Handler.Utils.Users import Handler.Utils.Users
import Handler.Utils.Invitations import Handler.Utils.Invitations
import Handler.Utils.Avs import Handler.Utils.Avs
import qualified Auth.LDAP as Auth
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set import qualified Data.Set as Set
@ -35,8 +32,6 @@ import qualified Data.ByteString.Base64 as Base64
import Data.Aeson hiding (Result(..)) import Data.Aeson hiding (Result(..))
-- import Handler.Users.Add as Handler.Users
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
@ -130,8 +125,8 @@ postUsersR = do
icnReroute = text2widget " " <> toWgt (icon IconLetter) icnReroute = text2widget " " <> toWgt (icon IconLetter)
pure $ mconcat supervisors pure $ mconcat supervisors
, sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication , 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 "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 -- , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation -- TODO: reintroduce via ExternalAuth
, flip foldMap universeF $ \function -> , flip foldMap universeF $ \function ->
sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do 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 schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
@ -226,15 +221,15 @@ postUsersR = do
, ( "company-department" , ( "company-department"
, SortColumn $ \user -> user E.^. UserCompanyDepartment , SortColumn $ \user -> user E.^. UserCompanyDepartment
) )
, ( "auth-ldap" -- , ( "auth-ldap"
, SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP -- , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
) -- ) -- TODO: reintroduce via ExternalAuth
, ( "last-login" , ( "last-login"
, SortColumn $ \user -> user E.^. UserLastAuthentication , SortColumn $ \user -> user E.^. UserLastAuthentication
) )
, ( "ldap-sync" -- , ( "ldap-sync"
, SortColumn $ \user -> user E.^. UserLastLdapSynchronisation -- , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
) -- ) -- TODO: reintroduce via ExternalAuth
, ( "user-company" , ( "user-company"
, SortColumn $ \user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do , SortColumn $ \user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId 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? | 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 | otherwise -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria
) )
, ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if -- , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if
| Just crit <- getLast criterion -- | Just crit <- getLast criterion
-> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit -- -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit
| otherwise -- | otherwise
-> E.true -- -> E.true
) -- ) -- TODO: reintroduce via ExternalAuth
, ( "school", FilterColumn $ \user criterion -> if , ( "school", FilterColumn $ \user criterion -> if
| Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> let schools = E.valList (Set.toList criterion) in | otherwise -> let schools = E.valList (Set.toList criterion) in
E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId
E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools
) )
, ( "ldap-sync", FilterColumn $ \user criteria -> if -- , ( "ldap-sync", FilterColumn $ \user criteria -> if
| Just criteria' <- fromNullable criteria -- | Just criteria' <- fromNullable criteria
-> let minTime = minimum (criteria' :: NonNull (Set UTCTime)) -- -> let minTime = minimum (criteria' :: NonNull (Set UTCTime))
in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation -- in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
| otherwise -> E.val True :: E.SqlExpr (E.Value Bool) -- | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
) -- ) -- TODO: reintroduce via ExternalAuth
, ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion -> , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` 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 "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) , 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 "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 "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) -- , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) -- TODO: reintroduce via ExternalAuth
] ]
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = DBParamsForm , dbtParams = DBParamsForm
@ -364,7 +359,7 @@ postUsersR = do
| Set.null usersSet && isNotSetSupervisor act -> | Set.null usersSet && isNotSetSupervisor act ->
addMessageI Info MsgActionNoUsersSelected addMessageI Info MsgActionNoUsersSelected
(UserLdapSyncData, userSet) -> do (UserLdapSyncData, userSet) -> do
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseUserdbUser uid forM_ userSet $ queueJob' . JobSynchroniseUser
addMessageI Success . MsgSynchroniseUserdbUserQueued $ Set.size userSet addMessageI Success . MsgSynchroniseUserdbUserQueued $ Set.size userSet
redirectKeepGetParams UsersR redirectKeepGetParams UsersR
(UserAvsSyncData, userSet) -> do (UserAvsSyncData, userSet) -> do
@ -400,7 +395,7 @@ postUsersR = do
formResult allUsersRes $ \case formResult allUsersRes $ \case
AllUsersLdapSync -> do AllUsersLdapSync -> do
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUserdbUser . entityKey) runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUser . entityKey)
addMessageI Success MsgSynchroniseUserdbAllUsersQueued addMessageI Success MsgSynchroniseUserdbAllUsersQueued
redirect UsersR redirect UsersR
let allUsersWgt' = wrapForm allUsersWgt def let allUsersWgt' = wrapForm allUsersWgt def
@ -506,7 +501,7 @@ postAdminUserR uuid = do
return (result, $(widgetFile "widgets/user-rights-form/user-rights-form")) return (result, $(widgetFile "widgets/user-rights-form/user-rights-form"))
userAuthenticationForm :: Form ButtonAuthMode userAuthenticationForm :: Form ButtonAuthMode
userAuthenticationForm = buttonForm' $ if userAuthenticationForm = buttonForm' $ if
| userAuthentication == AuthLDAP -> [BtnAuthPWHash] | is _Nothing userPasswordHash -> [BtnAuthPWHash]
| otherwise -> [BtnAuthLDAP, BtnPasswordReset] | otherwise -> [BtnAuthLDAP, BtnPasswordReset]
systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False
where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func
@ -532,33 +527,41 @@ postAdminUserR uuid = do
redirect $ AdminUserR uuid redirect $ AdminUserR uuid
userAuthenticationAction = \case userAuthenticationAction = \case
BtnAuthLDAP -> do -- TODO WIP BtnAuthLDAP -> do -- TODO: Reformulate messages and constructors to "remove pw hash" or "external login only"
let -- let
campusHandler :: MonadPlus m => Auth.CampusUserException -> m a -- ldapHandler :: MonadPlus m => Auth.LdapUserException -> m a
campusHandler _ = mzero -- ldapHandler _ = mzero
campusResult <- runMaybeT . handle campusHandler $ do -- ldapResult <- runMaybeT . handle ldapHandler $ do
Just pool <- getsYesod $ view _appLdapPool -- Just pool <- getsYesod $ view _appLdapPool
void . lift . Auth.ldapUser pool $ Creds Auth.apLdap (CI.original userIdent) [] -- void . lift . Auth.ldapUser pool $ Creds Auth.apLdap (CI.original userIdent) []
case campusResult of -- case ldapResult of
Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup -- Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
_other -- _other
| is _AuthLDAP userAuthentication -- | is _AuthLDAP userAuthentication
-> addMessageI Info MsgAuthLDAPAlreadyConfigured -- -> addMessageI Info MsgAuthLDAPAlreadyConfigured
Just () -> do -- Just () -> do
runDBJobs $ do -- runDBJobs $ do
update uid [ UserAuthentication =. AuthLDAP ] -- update uid [ UserAuthentication =. AuthLDAP ]
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid -- 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 addMessageI Success MsgAuthLDAPConfigured
redirect $ AdminUserR uuid redirect $ AdminUserR uuid
BtnAuthPWHash -> do BtnAuthPWHash -> do
if if
| is _AuthPWHash userAuthentication | is _Just userPasswordHash
-> addMessageI Info MsgAuthPWHashAlreadyConfigured -> addMessageI Info MsgAuthPWHashAlreadyConfigured
| otherwise | otherwise
-> do -> do
runDBJobs $ do runDBJobs $ do
update uid [ UserAuthentication =. AuthPWHash "" ] update uid [ UserPasswordHash =. Just "" ]
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
queueDBJob $ JobSendPasswordReset uid queueDBJob $ JobSendPasswordReset uid
@ -718,18 +721,18 @@ postUserPasswordR cID = do
isAdmin <- hasWriteAccessTo $ AdminUserR cID isAdmin <- hasWriteAccessTo $ AdminUserR cID
requireCurrent <- maybeT (return True) $ asum requireCurrent <- maybeT (return True) $ asum
[ False <$ guard (isn't _AuthPWHash userAuthentication) [ False <$ guard (isn't _Just userPasswordHash)
, False <$ guard isAdmin , False <$ guard isAdmin
, do , do
authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $ unless (authMode `constEq` computeUserAuthenticationDigest userPasswordHash) . lift $
invalidArgsI [MsgUnauthorizedPasswordResetToken] invalidArgsI [MsgUnauthorizedPasswordResetToken]
return False return False
] ]
((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
currentResult <- if currentResult <- if
| AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication | Just (encodeUtf8 -> pwHash) <- userPasswordHash
, requireCurrent , requireCurrent
-> wreq -> wreq
(checkMap (bool (Left MsgCurrentPasswordInvalid) (Right ()) . flip (PWStore.verifyPasswordWith pwHashAlgorithm (2^)) pwHash . encodeUtf8) (const "") passwordField) (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 formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do
newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength 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 tell . pure =<< messageI Success MsgPasswordChangedSuccess
siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{userEmailWidget usr}|] $ siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{userEmailWidget usr}|] $