chore(avs): add avs synch background jobs towards #34

models/avs.model

@@ -17,6 +17,7 @@ UserAvs
   personId        AvsPersonId -- unique identifier for user throughout avs; newtype for Int  
   user            UserId
   noPerson        Int         default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle
+  lastSynch       UTCTime     default=now()
   UniqueUserAvsUser user
   UniqueUserAvsId   personId
   deriving Generic Show

src/Handler/Utils/Avs.hs

@@ -409,6 +409,7 @@ upsertAvsUserByCard persNo = do
 upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId)
 upsertAvsUserById api = do
   mbapd <- lookupAvsUser api
+  now <- liftIO getCurrentTime
   mbuid <- runDB $ do
     mbuid <- getBy (UniqueUserAvsId api)
     case (mbuid, mbapd) of
@@ -417,17 +418,20 @@ upsertAvsUserById api = do
             $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo
             candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
             case candidates of
-              [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo)
+              [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now)
               (_:_) -> throwM $ AvsUserAmbiguous api
               [] -> do
                 upsRes :: Either SomeException (Entity User)
                   <- try $ ldapLookupAndUpsert persNo
                 $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 -- pin/addr are updated in next step anyway
+                  Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now -- pin/addr are updated in next step anyway
                   Left err -> do 
                     $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err
                     return mbuid -- == Nothing -- user could not be created somehow
+      (Just Entity{ entityKey = uaid }, _) -> do
+        update uaid [ UserAvsLastSynch =. now ] -- mark as updated early, to prevent failed users to clog the synch
+        return mbuid
       _other -> return mbuid
   $logInfoS "AVS" $ "upsert prestep result: " <> tshow mbuid <> " --- " <> tshow mbapd
   case (mbuid, mbapd) of
@@ -460,9 +464,8 @@ upsertAvsUserById api = do
             , audAuth  = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
             }
       mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
-      whenIsJust mbUid $ \uid -> runDB $ do
+      whenIsJust mbUid $ \uid -> runDB $ do        
-        now <- liftIO getCurrentTime
+        insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now
-        insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo
         forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred
         -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
         -- forM_ cs $  -- only save used cards for the postal address update detection
@@ -475,15 +478,14 @@ upsertAvsUserById api = do
       let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards          
           userFirmAddr    = plaintextToStoredMarkup <$> mbCoFirmAddr
           pinCard         = Set.lookupMax avsPersonPersonCards
-          userPin         = personCard2pin <$> pinCard                    
+          userPin         = personCard2pin <$> pinCard                          
-      now <- liftIO getCurrentTime
+      runDB $ do        
-      runDB $ do
         update uid  [ UserFirstName             =. avsFirstName      -- update in case of name changes via AVS; might be changed again through LDAP
                     , UserSurname               =. avsSurname
                     , UserDisplayName           =. avsFirstName <> Text.cons ' ' avsSurname
                     , UserMatrikelnummer        =. Just (tshow avsPersonPersonNo)  -- TODO: Deactivate this update after Q2/2023; this is only needed since UserMatrikelnummer was used for AVSNO later
                     , UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
-                    ]        
+                    ]     
         oldCards <- selectList [UserAvsCardPersonId ==. api] []
         let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards
         unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do  -- update postal address, unless the exact address had been seen before

src/Jobs.hs

@@ -72,6 +72,7 @@ import Jobs.Handler.Invitation
 import Jobs.Handler.SendPasswordReset
 import Jobs.Handler.TransactionLog
 import Jobs.Handler.SynchroniseLdap
+import Jobs.Handler.SynchroniseAvs
 import Jobs.Handler.PruneInvitations
 import Jobs.Handler.ChangeUserDisplayEmail
 import Jobs.Handler.Files

src/Jobs/Handler/SynchroniseAvs.hs

@@ -0,0 +1,44 @@
+-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <s.jost@fraport.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Jobs.Handler.SynchroniseAvs
+  ( dispatchJobSynchroniseAvsId
+  , dispatchJobSynchroniseAvsUser
+  ) where
+
+import Import
+
+import Handler.Utils.Avs
+
+
+{- TODO: general AVS synchronisation 
+dispatchJobSynchroniseLdap :: Natural -> Natural -> Natural -> JobHandler UniWorX
+dispatchJobSynchroniseLdap numIterations epoch iteration
+  = JobHandlerAtomic . runConduit $
+      readUsers .| filterIteration .| sinkDBJobs
+  where
+    readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
+    readUsers = selectKeys [] []
+
+    filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
+    filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
+      let
+        userIteration, currentIteration :: Integer
+        userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
+        currentIteration = toInteger iteration `mod` toInteger numIterations
+      $logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
+      guard $ userIteration == currentIteration
+
+      return $ JobSynchroniseLdapUser userId
+-}
+
+
+dispatchJobSynchroniseAvsId :: AvsPersonId -> JobHandler UniWorX
+dispatchJobSynchroniseAvsId = JobHandlerException . void . upsertAvsUserById  -- updates UserAvsLAstSynch
+
+dispatchJobSynchroniseAvsUser :: UserId -> JobHandler UniWorX
+dispatchJobSynchroniseAvsUser jUser = JobHandlerException $ do
+  runDB (getBy $ UniqueUserAvsUser jUser) >>= \case
+    Nothing         -> return () -- no attempt to associate an AVS user is done here
+    Just usrAvsEnt  -> void $ upsertAvsUserById $ usrAvsEnt ^. _entityVal . _userAvsPersonId -- updates UserAvsLAstSynch

src/Jobs/Types.hs

@@ -84,12 +84,13 @@ data Job
   | JobTruncateTransactionLog
   | JobPruneInvitations
   | JobDeleteTransactionLogIPs
-  | JobSynchroniseLdap { jNumIterations
+  | JobSynchroniseLdap        { jNumIterations
-                       , jEpoch
+                              , jEpoch
-                       , jIteration :: Natural
+                              , jIteration :: Natural
-                       }
+                              }
-  | JobSynchroniseLdapUser { jUser :: UserId
+  | JobSynchroniseLdapUser    { jUser :: UserId }
-                           }
+  | JobSynchroniseAvsUser     { jUser :: UserId }
+  | JobSynchroniseAvsId       { jAvsId:: AvsPersonId }
   | JobChangeUserDisplayEmail { jUser :: UserId
                               , jDisplayEmail :: UserEmail
                               }
@@ -326,6 +327,8 @@ jobNoQueueSame = \case
   JobPruneInvitations{}               -> Just JobNoQueueSame
   JobDeleteTransactionLogIPs{}        -> Just JobNoQueueSame
   JobSynchroniseLdapUser{}            -> Just JobNoQueueSame
+  JobSynchroniseAvsUser{}             -> Just JobNoQueueSame
+  JobSynchroniseAvsId{}               -> Just JobNoQueueSame
   JobChangeUserDisplayEmail{}         -> Just JobNoQueueSame
   JobPruneSessionFiles{}              -> Just JobNoQueueSameTag
   JobPruneUnreferencedFiles{}         -> Just JobNoQueueSameTag

test/Database/Fill.hs

@@ -568,7 +568,7 @@ fillDb = do
   matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
   manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
   matUsers <- selectList [UserMatrikelnummer !=. Nothing] []
-  insertMany_ [UserAvs (AvsPersonId n) uid n | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers]
+  insertMany_ [UserAvs (AvsPersonId n) uid n now | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers]
   
   let tmin   = -1
       tmax   = 2
@@ -674,12 +674,12 @@ fillDb = do
     void . insert' $ UserSchool uid mi False
   for_ [jost] $ \uid ->
     void . insert' $ UserSchool uid avn False
-  void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321
+  void . insert' $ UserAvs (AvsPersonId 12345678) jost        87654321  (n_day' $ -12)
-  void . insert' $ UserAvs (AvsPersonId 2) svaupel 2
+  void . insert' $ UserAvs (AvsPersonId 2)        svaupel     2         (n_day' $ -22)
-  void . insert' $ UserAvs (AvsPersonId 3) gkleen 3
+  void . insert' $ UserAvs (AvsPersonId 3)        gkleen      3         (n_day' $ -32)
-  void . insert' $ UserAvs (AvsPersonId 4) sbarth 4
+  void . insert' $ UserAvs (AvsPersonId 4)        sbarth      4         now
-  void . insert' $ UserAvs (AvsPersonId 5) fhamann 5
+  void . insert' $ UserAvs (AvsPersonId 5)        fhamann     5         now
-  void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77
+  void . insert' $ UserAvs (AvsPersonId 77)       tinaTester  77        now
   insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True  Nothing Nothing AvsCardColorGelb (Set.fromList ['F'])     Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now
   insert_ $ UserAvsCard (AvsPersonId 2)        (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True  Nothing Nothing AvsCardColorRot  (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now
   insert_ $ UserAvsCard (AvsPersonId 3)        (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot  (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now