From 51298ba726ecfe4e0e1ca2303167422018b86bd5 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 8 Mar 2024 19:05:58 +0100 Subject: [PATCH] chore: make fetch and upsert results Maybe --- src/Foundation/Yesod/Auth.hs | 98 +++++++++++++------------------ src/Handler/Admin/ExternalUser.hs | 2 +- src/Handler/Utils/Avs.hs | 15 +++-- src/Handler/Utils/Users.hs | 30 ++++------ 4 files changed, 64 insertions(+), 81 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 1c1de9262..2c0ffc3ef 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -5,7 +5,7 @@ module Foundation.Yesod.Auth ( authenticate , userLookupAndUpsert - , upsertUser + , upsertUser, maybeUpsertUser , decodeUserTest , DecodeUserException(..) , updateUserLanguage @@ -22,7 +22,7 @@ import Foundation.Type import Foundation.Types import Foundation.I18n -import Handler.Utils.Profile +-- import Handler.Utils.Profile import Handler.Utils.LdapSystemFunctions import Handler.Utils.Memcached import Foundation.Authorization (AuthorizationCacheKey(..)) @@ -112,22 +112,12 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend flip catches excHandlers $ if | not isDummy, not isOther - -- , UserAuthConfSingleSource (AuthSourceConfAzureAdV2 upsertUserAzureConf) <- userAuthConf - , Just upsertMode' <- upsertMode -> do - userData <- fetchUserData Creds{..} + , Just upsertMode' <- upsertMode -> fetchUserData Creds{..} >>= \case + Just userData -> do $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData Authenticated . entityKey <$> upsertUser upsertMode' userData - -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..} - -- upsertUserAzureData <- azureUser upsertUserAzureConf Creds{..} - -- $logDebugS "AuthAzure" $ "Successful Azure lookup: " <> tshow upsertUserAzureData - -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataAzure{..} - -- | not isDummy, not isOther - -- , UserAuthConfSingleSource (AuthSourceConfLdap upsertUserLdapConf) <- userAuthConf - -- , Just upsertMode' <- upsertMode -> do - -- ldapPool <- fmap (fromMaybe $ error "No LDAP Pool") . getsYesod $ view _appLdapPool - -- upsertUserLdapData <- ldapUser ldapPool Creds{..} - -- $logDebugS "AuthLDAP" $ "Successful LDAP lookup: " <> tshow upsertUserLdapData - -- Authenticated . entityKey <$> upsertUser upsertMode' UpsertUserDataLdap{..} + Nothing + -> throwM FetchUserDataNoResult | otherwise -> acceptExisting @@ -176,9 +166,9 @@ userLookupAndUpsert :: forall m. ) => Text -> UpsertUserMode - -> SqlPersistT m (Entity User) + -> SqlPersistT m (Maybe (Entity User)) userLookupAndUpsert credsIdent mode = - fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= upsertUser mode + fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= maybeUpsertUser mode data FetchUserDataException @@ -197,23 +187,23 @@ fetchUserData :: forall m site. , MonadUnliftIO m ) => Creds site - -> SqlPersistT m (NonEmpty UpsertUserData) -fetchUserData creds@Creds{..} = do + -> SqlPersistT m (Maybe (NonEmpty UpsertUserData)) +fetchUserData Creds{..} = do userAuthConf <- getsYesod $ view _appUserAuthConf now <- liftIO getCurrentTime - results :: NonEmpty UpsertUserData <- case userAuthConf of - UserAuthConfSingleSource{..} -> (:| []) <$> case userAuthConfSingleSource of + results :: Maybe (NonEmpty UpsertUserData) <- case userAuthConf of + UserAuthConfSingleSource{..} -> fmap (:| []) <$> case userAuthConfSingleSource of AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case - Right upsertUserAzureData -> return UpsertUserDataAzure{..} - Left _ -> throwM FetchUserDataNoResult - AuthSourceConfLdap LdapConf{..} -> do - ldapPool <- fmap (fromMaybe $ error "LDAP source configured, but no LDAP pool initialized") . getsYesod $ view _appLdapPool - UpsertUserDataLdap ldapConfSourceId <$> ldapUser ldapPool creds + Right upsertUserAzureData -> return $ Just UpsertUserDataAzure{..} + Left _ -> return Nothing + AuthSourceConfLdap LdapConf{..} -> getsYesod (view _appLdapPool) >>= \case + Just ldapPool -> fmap (UpsertUserDataLdap ldapConfSourceId) <$> ldapUser'' ldapPool credsIdent + Nothing -> throwM FetchUserDataException -- insert ExternalUser entries for each fetched dataset - forM_ results $ \res -> + whenIsJust results $ \ress -> forM_ ress $ \res -> let externalUserUser = error "no userid" -- TODO: use azureUserPrimaryKey/ldapPrimaryKey once UserIdent is referenced instead of UserId externalUserLastSync = now (externalUserData, externalUserSource) = case res of @@ -225,15 +215,16 @@ fetchUserData creds@Creds{..} = do -- | Upsert User and related auth in DB according to given external source data (does not query source itself) -upsertUser :: forall m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) - => UpsertUserMode - -> NonEmpty UpsertUserData - -> SqlPersistT m (Entity User) -upsertUser _upsertMode upsertData = do +maybeUpsertUser :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + ) + => UpsertUserMode + -> Maybe (NonEmpty UpsertUserData) + -> SqlPersistT m (Maybe (Entity User)) +maybeUpsertUser _upsertMode Nothing = return Nothing +maybeUpsertUser _upsertMode (Just upsertData) = do now <- liftIO getCurrentTime userDefaultConf <- getsYesod $ view _appUserDefaults @@ -242,27 +233,10 @@ 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 (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate - -- sets display name - -- TODO: use display name from external source, if possible - unless (validDisplayName (newUser ^. _userTitle) - (newUser ^. _userFirstName) - (newUser ^. _userSurname) - (userRec ^. _userDisplayName)) $ - update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] - - -- TODO updates ident with email - refactor and/or remove with Azure! (email /= ident in azure) - -- when (validEmail' (userRec ^. _userEmail)) $ do - -- let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ] - -- ++ [ UserAuthentication =. AuthLDAP | is _AuthNoLogin (userRec ^. _userAuthentication) ] - -- unless (null emUps) $ update userId emUps - -- -- Attempt to update ident, too: - -- unless (validEmail' (userRec ^. _userIdent)) $ - -- void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ())) - let userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' userSystemFunctions' = concat $ upsertData <&> \case @@ -283,7 +257,19 @@ upsertUser _upsertMode upsertData = do if | preset -> void $ upsert (UserSystemFunction userId func False False) [] | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] - return user + return $ Just user + +upsertUser :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + ) + => UpsertUserMode + -> NonEmpty UpsertUserData + -> SqlPersistT m (Entity User) +upsertUser upsertMode upsertData = maybeUpsertUser upsertMode (Just upsertData) >>= \case + Nothing -> error "upsertUser: No user result from maybeUpsertUser!" + Just user -> return user decodeUser :: ( MonadThrow m diff --git a/src/Handler/Admin/ExternalUser.hs b/src/Handler/Admin/ExternalUser.hs index 1d5d11ab4..2a7226765 100644 --- a/src/Handler/Admin/ExternalUser.hs +++ b/src/Handler/Admin/ExternalUser.hs @@ -54,7 +54,7 @@ postAdminExternalUserR = do ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminExternalUserUpsert"::Text) $ \html -> flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing let procFormUpsert :: Text -> Handler (Maybe (Entity User)) - procFormUpsert lid = pure <$> runDB (userLookupAndUpsert lid UpsertUserGuessUser) + procFormUpsert lid = runDB (userLookupAndUpsert lid UpsertUserGuessUser) mbUpsert <- formResultMaybe uresult procFormUpsert diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 3743dcd8f..222ec4ba6 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -355,9 +355,9 @@ guessAvsUser someid = do _ -> return Nothing uid -> return uid Nothing -> try (runDB $ userLookupAndUpsert someid UpsertUserGuessUser) >>= \case - Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> + Right (Just Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)) - Right Entity{entityKey=uid} -> return $ Just uid + Right (Just Entity{entityKey=uid}) -> return $ Just uid other -> do -- attempt to recover by trying other ids whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser external error " <> tshow err) -- this line primarily forces exception type to catch-all runDB . runMaybeT $ @@ -370,7 +370,7 @@ upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail try (runDB $ userLookupAndUpsert otherId UpsertUserGuessUser) >>= \case - Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) + Right (Just Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) other -> do -- attempt to recover by trying other ids whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all apid <- runDB . runMaybeT $ do @@ -419,13 +419,16 @@ upsertAvsUserById api = do [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing) (_:_) -> throwM $ AvsUserAmbiguous api [] -> do - upsRes :: Either SomeException (Entity User) + upsRes :: Either SomeException (Maybe (Entity User)) <- try $ userLookupAndUpsert persNo UpsertUserGuessUser -- TODO: do azure lookup and upsert if appropriate $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes case upsRes of - Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway + Right (Just Entity{entityKey=uid}) -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway + Right Nothing -> do + $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases" + return mbuid -- == Nothing -- user could not be created somehow Left err -> do - $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err + $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases: " <> tshow err return mbuid -- == Nothing -- user could not be created somehow (Just Entity{ entityKey = uaid }, _) -> do update uaid [ UserAvsLastSynch =. now, UserAvsLastSynchError =. Nothing ] -- mark as updated early, to prevent failed users to clog the synch diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 2580d1700..0e59307d7 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -24,8 +24,7 @@ module Handler.Utils.Users ) where import Import -import Auth.LDAP (ldapUserMatr') -import Foundation.Yesod.Auth (upsertUser) +import Foundation.Yesod.Auth (userLookupAndUpsert) import Crypto.Hash (hashlazy) @@ -192,7 +191,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname' GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName' - go didLdap = do + go didUpsert = do let retrieveUsers = E.select . EL.from $ \user -> do E.where_ . E.or $ map (E.and . map (toSql user)) criteria when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit @@ -234,12 +233,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) | EQ <- x `closeness` x' = x : takeClosest (x':xs) | otherwise = [x] - -- TODO: Generalize - doLdap userMatr = do - ldapPool' <- getsYesod $ view _appLdapPool - fmap join . for ldapPool' $ \ldapPool@(LdapConf{ ldapConfSourceId = upsertUserLdapHost },_) -> do - ldapData <- ldapUserMatr' ldapPool userMatr - for ldapData $ \upsertUserLdapData -> upsertUser UpsertUserGuessUser $ UpsertUserDataLdap{..} :| [] + doUpsert = flip userLookupAndUpsert UpsertUserGuessUser let getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation @@ -255,25 +249,25 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) | otherwise = Nothing getTermMatrAux acc (_:xs) = getTermMatrAux acc xs - convertLdapResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User)) - convertLdapResults [] = Nothing - convertLdapResults [x] = Just $ Right x - convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs + convertUpsertResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User)) + convertUpsertResults [] = Nothing + convertUpsertResults [x] = Just $ Right x + convertUpsertResults xs = Just $ Left $ NonEmpty.fromList xs if | [x] <- users' - , Just True == matchesMatriculation x || didLdap + , Just True == matchesMatriculation x || didUpsert -> return $ Just $ Right x | x : x' : _ <- users' - , Just True == matchesMatriculation x || didLdap + , Just True == matchesMatriculation x || didUpsert , GT <- x `closeness` x' -> return $ Just $ Right x | xs@(x:_:_) <- takeClosest users' - , Just True == matchesMatriculation x || didLdap + , Just True == matchesMatriculation x || didUpsert -> return $ Just $ Left $ NonEmpty.fromList xs - | not didLdap + | not didUpsert , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria - -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes + -> mapM doUpsert userMatrs >>= maybe (go True) (return . Just) . convertUpsertResults . catMaybes | otherwise -> return Nothing