refactor(avs): rework upsertAvsUserByCard/Id

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

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

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
+lookupAvsUsers apis = do  
-  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+  AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
-  AvsResponseStatus statuses <- throwLeftM . avsQueryStatus $ 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
+updateAvsUserByIds apids0  = do    
-    AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched!
+    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 
+      runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
-        [     Entity{entityVal=UserAvs{userAvsUser=uid}}] ->          Just uid
-        _ -> Nothing -- not existing or not unique 
 guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =  
     maybeCatchAll $ upsertAvsUserByCard someavsid >>= \case
       Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
-        runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) <&> \case
+        runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
-            [Entity{entityKey=uid}]                       ->          Just uid
-            _ -> Nothing -- not existing or not unique
       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,

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
+```

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
     }

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

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]
+(~~.) f (Just v)  = [f ==. Nothing] ||. [f ==. Just v]