chore: make fetch and upsert results Maybe
This commit is contained in:
parent
96e3eb613d
commit
51298ba726
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user