refactor(avs): complete createAvsUserById

messages/uniworx/categories/avs/de-de-formal.msg

@@ -48,3 +48,4 @@ AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis
 AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse
 AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason}
 AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2}
+AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt.

messages/uniworx/categories/avs/en-eu.msg

@@ -48,3 +48,4 @@ AvsPersonSearchEmpty: AVS search returned empty result
 AvsPersonSearchAmbiguous: AVS search returned more than one result
 AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason}
 AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead
+AvsUserCreationFailed api@AvsPersonId: No new user could be created for AVS Id #{tshow api}, since an existing user shares at least one id presumed as unique

src/Handler/Utils/Avs.hs

@@ -76,7 +76,7 @@ data AvsException
   | AvsPersonSearchAmbiguous                  -- AvsPersonSearch returned more than one result
   | AvsSetLicencesFailed Text                 -- AvsSetLicence total failure
   | AvsIdMismatch AvsPersonId AvsPersonId     -- First AVS Id was requested, but second one was returned for that query
-  -- | AvsUserCreationFailed
+  | AvsUserCreationFailed AvsPersonId
   deriving (Show, Eq, Ord, Generic)
 instance Exception AvsException
 embedRenderMessage ''UniWorX ''AvsException id  -- display as feedback for user initiated actions -- moved to Foundation.I18n
@@ -360,7 +360,7 @@ updateReceivers uid = do
 -- TODO #36 "company postal preference", but for updates only yet
 --
 -- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do
-
+-- TODO: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables
 
 -- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
 class SomeAvsQuery q where 
@@ -615,61 +615,80 @@ updateAvsUserByIds apids0  = do
 -- | Create new user from AVS-Id. Will throw an AvsException if this is not possible, e.g. due to Uniqueness Constraints
 createAvsUserById :: AvsPersonId -> Handler UserId
 createAvsUserById api = do 
-  AvsResponseContact res <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
+  AvsResponseContact contactRes <- avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId api
-  case Set.toList res of
+  case Set.toList contactRes of
     []      -> throwM $ AvsUserUnknownByAvs api
     (_:_:_) -> throwM $ AvsUserAmbiguous    api
-    [AvsDataContact{avsContactPersonInfo=cpi,..}]
+    [AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
       | avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
       | otherwise -> do
-        usrCardNo <- queryAvsFullCardNo api
+        -- check for matching existing user
-        let pinPass = avsFullCardNo2pin <$> usrCardNo
-        Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany avsContactFirmInfo Nothing -- individual runDB, since no need to rollback
         let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
             persMail  :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI            
-            newUserData = AddUserData
+        oldUsr <- runDB $ do 
-              { audTitle            = Nothing                
+          mbUid <- firstJustM $ catMaybes
-              , audFirstName        = cpi ^. _avsInfoFirstName    & Text.strip
+                  [ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
-              , audSurname          = cpi ^. _avsInfoLastName     & Text.strip
+                  , persMail       <&> guessUserByEmail
-              , audDisplayName      = cpi ^. _avsInfoDisplayName                
+                  ]          
-              , audDisplayEmail     = persMail & fromMaybe mempty
+          mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
-              , audEmail            = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
+          return (mbUid, mbUAvs)
-              , audIdent            = persMail & fromMaybe ("AVSID:" <> ciShow api )
+        usrCardNo <- queryAvsFullCardNo api
-              , audAuth             = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
-              , audMatriculation    = cpi ^. _avsInfoPersonNo     & Just . tshow
-              , audSex              = Nothing
-              , audBirthday         = cpi ^. _avsInfoDateOfBirth
-              , audMobile           = cpi ^. _avsInfoPersonMobilePhoneNo 
-              , audTelephone        = Nothing
-              , audFPersonalNumber  = internalPersNo
-              , audFDepartment      = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)                  
-              , audPostAddress      = Nothing -- use company address indirectly
-              , audPrefersPostal    = cmp ^. _companyPrefersPostal
-              , audPinPassword      = pinPass
-              }
         now <- liftIO getCurrentTime
-        runDB $ do                                                                      -- any failure must rollback all DB write transactions          
+        let usrAvs uid mbFirmInfo = UserAvs
-          uid <- maybeThrowM AvsInterfaceUnavailable $ addNewUserDB newUserData         
-          let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
-          userCompId <- maybeThrowM AvsInterfaceUnavailable $ insertUnique userComp
-          -- TODO: link with existing user, if insertion failed?
-          -- TODO: write suitable exceptions, replacing all 3 AvsInterfaceUnavailable within this block
-          -- TODO: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables
-          -- Supervision
-          addCompanySupervisors cid uid
-          repsertSuperiorSupervisor (Just cid) avsContactFirmInfo uid
-          -- Save AVS data for future updates
-          userAvsId <- maybeThrowM AvsInterfaceUnavailable $ insertUnique UserAvs 
                   { userAvsPersonId       = api
                   , userAvsUser           = uid
                   , userAvsNoPerson       = fromMaybe (negate $ avsPersonId api) $ readMay $ cpi ^. _avsInfoPersonNo -- negative personId as fallback, but readMay should never fail
                   , userAvsLastSynch      = now
                   , userAvsLastSynchError = Nothing
                   , userAvsLastPersonInfo = Just cpi
-                  , userAvsLastFirmInfo   = Just avsContactFirmInfo
+                  , userAvsLastFirmInfo   = mbFirmInfo
                   , userAvsLastCardNo     = usrCardNo
                   }  
-          return $ seq userCompId $ seq userAvsId uid
+        case oldUsr of 
+          (_ , Just Entity{entityVal=UserAvs{userAvsPersonId=api'}})  
+            | api /= api' -> throwM $ AvsIdMismatch api api'
+            | otherwise   -> throwM $ AvsUserUnknownByAvs api
+          (Just uid, Nothing) -> runDB $ do                     -- link with matching exisitng user
+            insert_ $ usrAvs uid Nothing                        -- company info should cause the user to be associated with the company during the update
+            updRes <- updateAvsUserByIds $ Set.singleton api       -- no loop, since updateAvsUserByIds does not call createAvsUserById
+            case Set.toList updRes of
+              [(api',uid')] | api == api' -> return uid' -- && uid == uid' -> return uid
+                            | otherwise   -> throwM $ AvsIdMismatch api api'
+              [] -> throwM $ AvsUserUnknownByAvs api
+              _  -> throwM $ AvsUserAmbiguous    api
+          (Nothing, Nothing) -> do 
+            Entity{entityKey=cid, entityVal=cmp} <- runDB $ upsertAvsCompany firmInfo Nothing -- individual runDB, since no need to rollback
+            let pinPass = avsFullCardNo2pin <$> usrCardNo
+                newUserData = AddUserData
+                  { audTitle            = Nothing                
+                  , audFirstName        = cpi ^. _avsInfoFirstName    & Text.strip
+                  , audSurname          = cpi ^. _avsInfoLastName     & Text.strip
+                  , audDisplayName      = cpi ^. _avsInfoDisplayName                
+                  , audDisplayEmail     = persMail & fromMaybe mempty
+                  , audEmail            = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
+                  , audIdent            = persMail & fromMaybe ("AVSID:" <> ciShow api )
+                  , audAuth             = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
+                  , audMatriculation    = cpi ^. _avsInfoPersonNo     & Just . tshow
+                  , audSex              = Nothing
+                  , audBirthday         = cpi ^. _avsInfoDateOfBirth
+                  , audMobile           = cpi ^. _avsInfoPersonMobilePhoneNo 
+                  , audTelephone        = Nothing
+                  , audFPersonalNumber  = internalPersNo
+                  , audFDepartment      = toMaybe (isJust internalPersNo) (cmp ^. _companyShorthand . _CI)                  
+                  , audPostAddress      = Nothing -- always use company address indirectly
+                  , audPrefersPostal    = cmp ^. _companyPrefersPostal
+                  , audPinPassword      = pinPass
+                  }
+            runDB $ do        -- any failure must rollback all DB write transactions here
+              uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData  
+              let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
+              void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
+              -- Supervision
+              addCompanySupervisors cid uid
+              repsertSuperiorSupervisor (Just cid) firmInfo uid
+              -- Save AVS data for future updates
+              insert_ $ usrAvs uid $ Just firmInfo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
+              return uid
       
 
 -- | upsert superior by eMail through LDAP only (currently no email search available in AVS)
@@ -762,11 +781,7 @@ guessAvsUser someid = do
       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                                  -- also see Handler.Utils.guessUserByEmail for a similar function, this one is more lenient, since a unique email is acceptable, even it would not be unique as DisplayEmail
+                MaybeT (guessUserByEmail $ stripCI someid)              -- recall that monadic actions are only executed until first success here
-          in    MaybeT (getKeyBy $ UniqueEmail          someIdent)        -- recall that monadic actions are only executed until first success here
-            <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
-            <|> MaybeT (getKeyByFilter [UserDisplayEmail ==. someIdent])
-            <|> MaybeT (getKeyBy $ UniqueLdapPrimaryKey $ Just someid)
             <|> MaybeT (getKeyByFilter [UserDisplayName  ==. someid])
 
 
@@ -797,7 +812,7 @@ upsertAvsUserById0 api = do
     [(api',uid)] 
       | api == api' -> return uid
       | otherwise   -> throwM $ AvsIdMismatch api api'         
-                       -- error  $ "Handler.Utils.Avs.updateAvsUSerByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "."
+                       -- error  $ "Handler.Utils.Avs.updateAvsUserByIds returned unasked user with AvsPersonId " <> show api' <> " for queried AvsPersonId " <> show api <> "."
     (_:_:_)         -> throwM $ AvsUserAmbiguous api
 
 

src/Handler/Utils/Users.hs

@@ -200,14 +200,17 @@ getSupervisees = do
 computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
 computeUserAuthenticationDigest = hashlazy . JSON.encode
 
+-- guessUserByCompanyPersonalNumber :: Text -> Text -> DB (Maybe UserId)
+-- guessUserByCompanyPersonalNumber surname ipn = getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn, UserSurname ==. surname]
+
 guessUserByEmail :: UserEmail -> DB (Maybe UserId)
-guessUserByEmail eml = getKeyByFilter $ ofoldl1Ex' (||.) $
+guessUserByEmail eml = firstJustM $
-  mcons (getFraportLogin (CI.original eml) <&> (\lgi ->
+  [ getKeyBy $ UniqueEmail          eml
-    [UserLdapPrimaryKey ==. Just lgi]))                           -- Note that we must exclude `==. Nothing` here!
+  , getKeyBy $ UniqueAuthentication eml -- aka UserIdent
-  [ [UserDisplayEmail   ==. eml]
+  , getKeyByFilter [UserDisplayEmail   ==. eml]
-  , [UserEmail          ==. eml]
+  ] <> maybeEmpty (getFraportLogin (CI.original eml)) (\lgi ->
-  , [UserIdent          ==. eml]      
+  [ getKeyBy $ UniqueLdapPrimaryKey $ Just lgi
-  ]
+  ])
 
 data GuessUserInfo
   = GuessUserMatrikelnummer

src/Handler/Utils/avs_callgraph.md

@@ -5,13 +5,16 @@
 flowchart LR;
   gau([guessAvsUser])
   %% uau([XupsertAvsUser])
-  uaubi[?upsertAvsUserById]
+  uaubi[upsertAvsUserById]
+  uaubis[upsertAvsUserByIds]
   uaubc[upsertAvsUserByCard]
   ldap[[ldapLookupAndUpsert]]
   lau[lookupAvsUser]
   laus[lookupAvsUsers - DEPRECATED?]
   gla[guessLicenceAddress - DEPRECATED]
   ur([?updateReceivers])
+  caubi[createAvsUserById]
+  ucomp[upsertAvsCompany]
 
   aqc{{AvsQueryContact}}
   aqp{{AvsQueryPerson}}
@@ -28,10 +31,14 @@ flowchart LR;
   %% uau-..->uaubi
   %% uau-..->uaubc
   
-  uaubi-.->lau
+  uaubi-->uaubis
-  uaubi-.->ldap
+  uaubi-->caubi-->uaubis
-  uaubi-.->gla
+  uaubis-->aqc
-uaubi-->aqc
+  caubi-->aqs
+  caubi-->aqc
+
+  caubi-->ucomp
+  uaubis-->ucomp
 
   lau-->laus
   laus-->aqs