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(auth): migrate password hash back to User model

Browse Source
This commit is contained in:
Sarah Vaupel 2024-02-19 02:24:31 +01:00
parent 9a5c487b2c
commit a1d8dc2e7e
6 changed files with 22 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
models/auth.model
View File

@ -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

3
models/users.model
View File

@ -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

11
src/Auth/PWHash.hs
View File

@ -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

9
src/Foundation/Authorization.hs
View File

@ -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

4
src/Foundation/Navigation.hs
View File

@ -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

22
src/Foundation/Yesod/Auth.hs
View File

@ -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 =