fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(avs): rework upsertAvsUserByCard/Id

Browse Source
This commit is contained in:
Steffen Jost 2024-04-12 17:27:46 +02:00
parent 1f7c175a58
commit 54c08cc64b
7 changed files with 148 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Database/Esqueleto/Utils.hs
View File

@ -32,6 +32,7 @@ module Database.Esqueleto.Utils
, orderByOrd, orderByEnum
, strip, lower, ciEq
, selectExists, selectNotExists
, filterExists
, SqlHashable
, sha256
, isTrue, isFalse
@ -510,6 +511,13 @@ selectExists query = do
_other -> error "SELECT EXISTS ... returned zero or more than one rows"
selectNotExists = fmap not . selectExists
filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
=> EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono]
filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do
ent <- Ex.from Ex.table
Ex.where_ $ ent Ex.^. prj `Ex.in_` vals vs
return $ ent Ex.^. prj
class SqlHashable a
instance SqlHashable Text

2
src/Handler/Admin/Avs.hs
View File

@ -681,7 +681,7 @@ getAdminAvsUserR uuid = do
uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
mbDataPerson <- lookupAvsUser userAvsPersonId
mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson

94
src/Handler/Utils/Avs.hs
View File

@ -149,7 +149,7 @@ upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid)
ifMaybeM apid Nothing upsertAvsUserById
-}
{-
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
upsertAvsUserByCard :: Either AvsInternalPersonalNo AvsFullCardNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
@ -168,7 +168,7 @@ upsertAvsUserByCard persNo = do
-- case mbuid of
-- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
-- Nothing -> upsertAvsUserById api
-}
-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS Licence status! Updates Company, Address, PinPassword
@ -279,6 +279,7 @@ upsertAvsUserById api = do
return $ Just uid
-- TODO: delete lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored!
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
AvsPersonId -> m (Maybe AvsDataPerson)
lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
@ -292,13 +293,12 @@ lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
-- Does not write to our own DB!
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
lookupAvsUsers apis = do
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ AvsQueryStatus apis
lookupAvsUsers apis = do
AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
let forFoldlM = $(permuteFun [3,2,1]) foldlM
forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
return $ mergeByPersonId adps acc2
@ -479,11 +479,20 @@ updateRecord dbv inp (CheckAvsUpdate up l) =
lensRec = fieldLensVal up
in dbv & lensRec .~ newval
{-
filterExisting :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> DB [AvsPersonId]
filterExisting apids = fmap E.unValue <<$>>
E.select $ do
usrAvs <- E.from $ E.table @UserAvs
E.where_ $ usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids
return $ usrAvs E.^. UserAvsPersonId
-}
-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism
-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism.
updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
updateAvsUserByIds apids = do
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched!
updateAvsUserByIds apids0 = do
apids <- Set.fromList <$> E.filterExists UserAvsPersonId apids0
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched
let requestedAnswers = Set.filter (view (_avsContactPersonID . to (`Set.member` apids))) adcs -- should not occur, neither should one apid occur multiple times within the response (if so, all responses processed here in random order)
res <- foldMapM procResp requestedAnswers
let missing = Set.toList $ Set.difference apids $ Set.map fst res
@ -607,6 +616,24 @@ updateAvsUserByIds apids = do
update uaId avs_ups
return $ Set.singleton (apid, usrId)
-- createAvsUserById :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) ???
createAvsUserById :: AvsPersonId -> Handler (Maybe UserId)
createAvsUserById api = do
AvsResponseContact res <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
case Set.toList res of
[] -> return Nothing
(_:_:_) -> throwM $ AvsUserAmbiguous api
[AvsDataContact{..}] -> runDB $ do
_now <- liftIO getCurrentTime
let uid = error "CONTINUE HERE"
Entity{entityKey=cid, entityVal=_} <- upsertAvsCompany avsContactFirmInfo Nothing
let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
void $ insertUnique userComp
return $ Just uid
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked. Highly unlikely that Nothing is returned, since all AvsResponseContact always contains an AvsFirmInfo
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
getAvsCompany afi =
@ -669,30 +696,59 @@ guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
Nothing -> maybeCatchAll $ upsertAvsUserById avsid
| prefix=="AVSNO:" =
runDB (selectList [UserAvsNoPerson ==. nr] []) <&> \case
[ Entity{entityVal=UserAvs{userAvsUser=uid}}] -> Just uid
_ -> Nothing -- not existing or not unique
runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
maybeCatchAll $ upsertAvsUserByCard someavsid >>= \case
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) <&> \case
[Entity{entityKey=uid}] -> Just uid
_ -> Nothing -- not existing or not unique
runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
other -> return other
guessAvsUser someid = do
try (runDB $ ldapLookupAndUpsert someid) >>= \case
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> -- ensure internal user is linked to avs, if possible
maybeCatchAll (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case
Nothing -> Just uid
Nothing -> Just uid
other -> other
Right Entity{entityKey=uid} -> return $ Just uid
Right Entity{entityKey=uid} -> return $ Just uid
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
runDB . runMaybeT $
let someIdent = stripCI someid
in MaybeT (getKeyBy $ UniqueEmail someIdent)
in MaybeT (getKeyBy $ UniqueEmail someIdent) -- recall that monadic actions are only executed until first success here
<|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
-- <|> MaybeT (getKeyBy $ UniqueLdapPrimaryKey someIdent)
<|> MaybeT (getKeyByFilter [UserDisplayEmail ==. someIdent])
<|> MaybeT (getKeyBy $ UniqueLdapPrimaryKey $ Just someid)
<|> MaybeT (getKeyByFilter [UserDisplayName ==. someid])
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
upsertAvsUserByCard :: Either AvsInternalPersonalNo AvsFullCardNo -> Handler (Maybe UserId)
upsertAvsUserByCard persNo = do
let qry = case persNo of
Left fpn
-> def{ avsPersonQueryInternalPersonalNo = Just fpn } -- recall: default has all fields set to nothing
Right AvsFullCardNo{..}
-> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
-- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB!
AvsResponsePerson adps <- avsQuery qry
case Set.elems adps of
[] -> throwM AvsPersonSearchEmpty
(_:_:_) -> throwM AvsPersonSearchAmbiguous
[AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always triggers an update
-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS licence status. Updates company, address, PinPassword
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
upsertAvsUserById0 :: AvsPersonId -> Handler (Maybe UserId)
upsertAvsUserById0 api = do
upd <- runDB (updateAvsUserByIds $ Set.singleton api)
case Set.toList upd of
[] -> createAvsUserById api
[(api',uid)]
| api == api' -> return $ Just uid
| otherwise -> error $ "Handler.Utils.Avs.updateAvsUSerByIds returned unasked user with API " <> show api' <> " for queried API " <> show api <> "."
(_:_:_) -> throwM $ AvsUserAmbiguous api
-- Licences
setLicence :: (PersistUniqueRead backend, MonadThrow m,

40
src/Handler/Utils/avs_callgraph.md Normal file
View File

@ -0,0 +1,40 @@
# Demo
## Mermaid Flowcharts
```mermaid
flowchart LR;
gau([guessAvsUser])
%% uau([XupsertAvsUser])
uaubi[?upsertAvsUserById]
uaubc[upsertAvsUserByCard]
ldap[[ldapLookupAndUpsert]]
lau[lookupAvsUser]
laus[lookupAvsUsers - DEPRECATED?]
gla[guessLicenceAddress - DEPRECATED]
ur([?updateReceivers])
aqc{{AvsQueryContact}}
aqp{{AvsQueryPerson}}
aqs{{AvsQueryStatus}}
uaubc-->uaubi
uaubc-->aqp
gau-->uaubi
gau-->uaubc
gau-->ldap
%% uau-..->uaubi
%% uau-..->uaubc
uaubi-.->lau
uaubi-.->ldap
uaubi-.->gla
uaubi-->aqc
lau-->laus
laus-->aqs
ur-->uaubi
```

5
src/Utils/Avs.hs
View File

@ -97,10 +97,11 @@ mkAvsQuery _ _ _ = AvsQuery
}
#else
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
{ avsQueryPerson = \q -> if q == def then return $ AvsResponsePerson mempty else -- prevent empty queries
liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (splitQuery rawQueryStatus q) cliEnv
, avsQueryContact = \q -> liftIO $ runClientM (splitQuery rawQueryContact q) cliEnv
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- TODO: currently uses setLicencesAvs for splitting to ensure return of correctly set licences
, avsQuerySetLicences = \q -> liftIO $ runClientM (rawQuerySetLicences q) cliEnv -- NOTE: currently uses setLicencesAvs for splitting to ensure return of correctly set licences
-- , avsQueryGetLicences = \q -> liftIO $ runClientM (rawQueryGetLicences q) cliEnv
, avsQueryGetAllLicences = liftIO $ runClientM (rawQueryGetLicences avsQueryAllLicences) cliEnv
}

18
src/Utils/DB.hs
View File

@ -2,6 +2,8 @@
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
-- also see Utils.Persist
module Utils.DB where
import ClassyPrelude.Yesod hiding (addMessageI)
@ -105,6 +107,22 @@ existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend,
=> Key record -> ReaderT backend m ()
existsKey404 = bool notFound (return ()) <=< existsKey
-- | given filter criteria like `selectList` this function returns Just if and only if there is precisely one result
getByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
=> [Filter record] -> ReaderT backend m (Maybe (Entity record))
getByFilter crit =
selectList crit [LimitTo 2] <&> \case
[singleEntity] -> Just singleEntity
_ -> Nothing -- not existing or not unique
getKeyByFilter :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
=> [Filter record] -> ReaderT backend m (Maybe (Key record))
getKeyByFilter crit =
selectKeysList crit [LimitTo 2] <&> \case
[singleKey] -> Just singleKey
_ -> Nothing -- not existing or not unique
updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
=> Unique record -> [Update record] -> ReaderT backend m ()
updateBy uniq updates = do

4
src/Utils/Persist.hs
View File

@ -2,6 +2,8 @@
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
-- also see Utils.DB
module Utils.Persist
( fromPersistValueError
, fromPersistValueErrorSql
@ -49,4 +51,4 @@ infix 4 ~~.
-- | maybe is equal or Nothing,
(~~.) :: PersistField a => EntityField v (Maybe a) -> Maybe a -> [Filter v]
(~~.) f Nothing = [f ==. Nothing]
(~~.) f (Just v) = [f ==. Nothing] ||. [f ==. Just v]
(~~.) f (Just v) = [f ==. Nothing] ||. [f ==. Just v]