From a1d8dc2e7eb31952ececd504b42d1b6700efb5c0 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 19 Feb 2024 02:24:31 +0100 Subject: [PATCH] chore(auth): migrate password hash back to User model --- models/auth.model | 7 ------- models/users.model | 3 ++- src/Auth/PWHash.hs | 11 ++++++----- src/Foundation/Authorization.hs | 9 ++++----- src/Foundation/Navigation.hs | 4 ++-- src/Foundation/Yesod/Auth.hs | 22 ++++++++-------------- 6 files changed, 22 insertions(+), 34 deletions(-) diff --git a/models/auth.model b/models/auth.model index 4f0420ecf..121d9440d 100644 --- a/models/auth.model +++ b/models/auth.model @@ -39,10 +39,3 @@ ExternalAuth lastSync UTCTime -- When was the corresponding User entry last synced with this external source? -- TODO rethink UniqueExternalAuth user source -- At most one entry of this user per source deriving Show Eq Ord Generic - --- | FraDrive-specific user authentication data, internal logins have precedence over external authentication -InternalAuth - user UserId - hash Text -- Hashed password - UniqueInternalAuth user - deriving Show Eq Ord Generic diff --git a/models/users.model b/models/users.model index 901d30bd9..7a2849968 100644 --- a/models/users.model +++ b/models/users.model @@ -14,6 +14,8 @@ User json -- Each Uni2work user has a corresponding row in this table; created upon first login. ident UserIdent -- Case-insensitive user-identifier + passwordHash Text Maybe -- If specified, allows the user to login with credentials independently of external authentication + lastLogin UTCTime Maybe -- When did the user last authenticate? surname UserSurname -- Display user names always through 'nameWidget displayName surname' displayName UserDisplayName displayEmail UserEmail @@ -47,7 +49,6 @@ User json -- Each Uni2work user has a corresponding row in this table; create prefersPostal Bool default=false -- user prefers letters by post instead of email examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default examOfficeGetLabels Bool default=true -- whether labels should be displayed for exam results by default - lastLogin UTCTime Maybe -- When did the user last authenticate? UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index fdb85bc8a..bd8664668 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -68,12 +68,13 @@ hashLogin pwHashAlgo = AuthPlugin{..} tp <- getRouteToParent resp <- formResultMaybe loginRes $ \HashLogin{..} -> Just <$> do - auth :: Maybe (Entity InternalAuth) <- liftHandler . runDB . getBy $ UniqueInternalAuth hashIdent - case auth of - Just (Entity _ InternalAuth{..}) - | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 internalAuthHash) -> do -- (2^) is magic. + user :: Maybe (Entity User) <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent + case user of + Just (Entity _ User{userIdent,userPasswordHash}) + | Just pwHash <- userPasswordHash + , verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 pwHash) -> do -- (2^) is magic. observeLoginOutcome apName LoginSuccessful - setCredsRedirect $ Creds apName (CI.original internalAuthUser) [] + setCredsRedirect $ Creds apName (CI.original userIdent) [] other -> do $logDebugS apName $ tshow other observeLoginOutcome apName LoginInvalidCredentials diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 4f36e5e31..b85e397d7 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1531,11 +1531,10 @@ tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return retu CourseR _ _ _ (CUserR cID) -> return cID _other -> throwError =<< $unsupportedAuthPredicate AuthIsExternal route referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser + let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents maybeTMExceptT (unauthorizedI MsgUnauthorizedExternal) $ do - User{..} <- MaybeT $ get referencedUser' - let availableSources = error "tagAccessPredicate: no available sources yet" -- TODO: implement once config supports source idents - guardM . lift $ exists [ ExternalAuthIdent ==. userIdent, ExternalAuthSource <-. availableSources ] - guardM . lift . fmap not . existsBy $ UniqueInternalAuth userIdent + Entity uid _ <- MaybeT $ getEntity referencedUser' + guardM . lift $ exists [ ExternalAuthUser ==. uid, ExternalAuthSource <-. availableSources ] return Authorized tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return return $ do referencedUser <- case route of @@ -1549,7 +1548,7 @@ tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return retu referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser maybeTMExceptT (unauthorizedI MsgUnauthorizedInternal) $ do User{..} <- MaybeT $ get referencedUser' - guardM . lift . existsBy $ UniqueInternalAuth userIdent + guard $ is _Just userPasswordHash return Authorized tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 6cdfe8b25..75cb1fdf7 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -1221,8 +1221,8 @@ pageActions (AdminUserR cID) = return , navRoute = UserPasswordR cID , navAccess' = NavAccessDB $ do uid <- decrypt cID - User{userIdent} <- get404 uid - existsBy $ UniqueInternalAuth userIdent + User{userPasswordHash} <- get404 uid + return $ is _Just userPasswordHash , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index d805aba9f..ee2b9fd7f 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -183,7 +183,7 @@ ldapLookupAndUpsert :: forall m. , MonadUnliftIO m ) => Text - -> SqlPersistT m (Entity UserAuth) + -> SqlPersistT m (Entity User) ldapLookupAndUpsert ident = getsYesod (view _appLdapPool) >>= \case Nothing -> throwM $ LdapUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." @@ -201,8 +201,8 @@ upsertUser :: forall m. ) => UpsertUserMode -> UpsertUserData - -> SqlPersistT m (Entity UserAuth) -upsertUser upsertMode upsertData = do + -> SqlPersistT m (Entity User) +upsertUser _upsertMode upsertData = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults @@ -211,9 +211,9 @@ upsertUser upsertMode upsertData = do oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] [] - _user@(Entity userId userRec) <- case oldUsers of + user@(Entity userId userRec) <- case oldUsers of [oldUserId] -> updateGetEntity oldUserId userUpdate - _other -> upsertBy (UniqueUser (newUser ^. _userIdent)) newUser userUpdate + _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate -- sets display name -- TODO: use display name from external source, if possible @@ -252,15 +252,7 @@ upsertUser upsertMode upsertData = do if | preset -> void $ upsert (UserSystemFunction userId func False False) [] | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] - let (userAuthLastLogin, userAuthLastSync) = case upsertMode of - UpsertUserSync{} -> (Nothing , Just now) - UpsertUserGuessUser{} -> (Nothing , Nothing ) - _other -> (Just now, Nothing ) - userAuth <- upsertBy (UniqueAuthentication $ newUser ^. _userIdent) UserAuth{ userAuthIdent = newUser ^. _userIdent, ..} $ - [ UserAuthLastLogin =. Just lastLogin | lastLogin <- maybeToList userAuthLastLogin ] ++ - [ UserAuthLastSync =. Just lastSync | lastSync <- maybeToList userAuthLastSync ] - - return userAuth + return user -- | Upsert User DB according to given Azure data (does not query Azure itself) -- upsertAzureUser :: forall m. @@ -396,6 +388,8 @@ decodeUser now UserDefaultConf{..} upsertData = do , userPostLastUpdate = Nothing , userPinPassword = Nothing -- must be derived via AVS , userPrefersPostal = userDefaultPrefersPostal + , userPasswordHash = Nothing + , userLastLogin = Nothing , .. } userUpdate =