diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 4bd3f85d3..3ca29691b 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -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 diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 1d7a05cf5..32675e9da 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index aed4dda0a..517940451 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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, diff --git a/src/Handler/Utils/avs_callgraph.md b/src/Handler/Utils/avs_callgraph.md new file mode 100644 index 000000000..ee642ae22 --- /dev/null +++ b/src/Handler/Utils/avs_callgraph.md @@ -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 +``` \ No newline at end of file diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index cfdda50fa..5f1b6613c 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -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 } diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index db94effe3..f9e5e09f3 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -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 diff --git a/src/Utils/Persist.hs b/src/Utils/Persist.hs index 29e67a404..154a8346c 100644 --- a/src/Utils/Persist.hs +++ b/src/Utils/Persist.hs @@ -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] \ No newline at end of file +(~~.) f (Just v) = [f ==. Nothing] ||. [f ==. Just v]