diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 0a893e211..b0bad05d8 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- 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}|] $