fix(avs): repeated avs sync enqueue no longe violates duplicate db uniqueness constraints

src/Handler/Admin.hs

@@ -95,7 +95,7 @@ handleAdminProblems mbProblemTable = do
     (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
     (Right AvsLicenceDifferences{..}) -> do
       let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
-      queueAvsUpdateByAID problemIds $ Just nowaday
+      void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday
       return $ Right
         ( Set.size avsLicenceDiffRevokeAll
         , Set.size avsLicenceDiffGrantVorfeld

src/Handler/Profile.hs

@@ -1270,6 +1270,6 @@ getAdminUserSyncLdapR uuid = do
 getAdminUserSyncAvsR :: CryptoUUIDUser -> Handler Html
 getAdminUserSyncAvsR uuid = do
   uid <- decrypt uuid
-  queueAvsUpdateByUID (Set.singleton uid) Nothing
+  n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing
-  addMessageI Success $ MsgSynchroniseAvsUserQueued 1
+  addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n
   redirectUltDest $ AdminUserR uuid

src/Handler/Users.hs

@@ -62,19 +62,20 @@ hijackUserForm = \csrf -> do
 -- instance HasUser   (DBRow (Entity USer)) where
 --    hasUser = _entityVal
 
-data UserAction = UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserAvsSync
+data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor 
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
 
 nullaryPathPiece ''UserAction $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''UserAction id
 
-data UserActionData = UserLdapSyncData 
+data UserActionData = UserAvsSyncData
+                    | UserLdapSyncData 
                     | UserHijack
                     | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } 
                     | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
                     | UserRemoveSupervisorData
-                    | UserAvsSyncData
+                    
   deriving (Eq, Ord, Read, Show, Generic)
   
 isNotSetSupervisor :: UserActionData -> Bool
@@ -369,8 +370,8 @@ postUsersR = do
       addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet      
       redirectKeepGetParams UsersR
     (UserAvsSyncData, userSet) -> do
-      queueAvsUpdateByUID userSet Nothing
+      n <- runDB $ queueAvsUpdateByUID userSet Nothing
-      addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
+      addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n
       redirectKeepGetParams UsersR
     (UserHijack, Set.lookupMin -> Just uid) ->
       hijackUser uid >>= sendResponse
@@ -404,16 +405,23 @@ postUsersR = do
       runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
       addMessageI Success MsgSynchroniseLdapAllUsersQueued
       redirect UsersR
-    AllUsersAvsSync -> do
+    AllUsersAvsSync -> do      
-      nowaday <- liftIO getCurrentTime <&> utctDay
+      now <- liftIO getCurrentTime
-      n <- runDB $ Ex.insertSelectCount $ do
+      let nowaday = utctDay now
-        usr <- Ex.from $ Ex.table @User
+      n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser
-        return (AvsSync
+        ( do
-            Ex.<#  (usr Ex.^. UserId)
+            usr <- Ex.from $ Ex.table @User
-            Ex.<&> E.now_
+            return (AvsSync
-            -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
+                Ex.<#  (usr Ex.^. UserId)
-            Ex.<&> E.justVal nowaday
+                Ex.<&> E.val now
-          )
+                -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
+                Ex.<&> E.justVal nowaday
+              )
+        ) (\current excluded -> 
+            [ AvsSyncCreationTime E.=. E.least    (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
+            , AvsSyncPause        E.=. E.greatest (current E.^. AvsSyncPause)        (excluded E.^. AvsSyncPause)
+            ]
+        )
       queueJob' JobSynchroniseAvsQueue
       addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n
       redirect UsersR

src/Handler/Utils/Avs.hs

@@ -61,7 +61,7 @@ import Handler.Utils.Memcached
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Utils        as E
--- import qualified Database.Esqueleto.PostgreSQL   as E
+import qualified Database.Esqueleto.PostgreSQL   as E
 
 import Servant.Client.Core.ClientError (ClientError)
 
@@ -648,24 +648,28 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
       ]
 
 
+queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64
+queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User)    (E.^. UserId)      (\usr    -> usr E.^. UserId             `E.in_` E.vals uids)
 
-queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler ()
+queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> DB Int64
-queueAvsUpdateByUID uids pause = do
+queueAvsUpdateByAID aids = queueAvsUpdateAux (E.table @UserAvs) (E.^. UserAvsUser) (\usrAvs -> usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids)
-  now <- liftIO getCurrentTime
-  runDB $ putMany [AvsSync uid now pause | uid <- toList uids]
-  queueJob' JobSynchroniseAvsQueue
 
-queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> Handler ()
+-- queueAvsUpdateAux :: E.From (E.SqlExpr (Entity ent)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value UserId)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
-queueAvsUpdateByAID aids pause = do
+queueAvsUpdateAux :: E.From t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
-  now <- liftIO getCurrentTime
+queueAvsUpdateAux tbl prj fltr pause = do 
-  runDB $ do
+  now <- liftIO getCurrentTime  
-    uids <- E.select $ do
+  n <- E.insertSelectWithConflictCount UniqueAvsSyncUser
-      usrAvs <- E.from $ E.table @UserAvs
+        ( do
-      E.where_ $ usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids
+            usr <- E.from tbl
-          -- E.&&. (E.isNothing pause E.||. pause E.>. E.dayMaybe (usrAvs  E.?. UserAvsLastSynch))   -- pause is checked later on in JobSynchroniseAvsQueue
+            E.where_ $ fltr usr
-      return $ usrAvs E.^. UserAvsUser
+            return (AvsSync E.<# prj usr E.<&> E.val now E.<&> E.val pause)
-    putMany [AvsSync uid now pause | E.Value uid <- uids]
+        ) (\current excluded -> 
-  queueJob' JobSynchroniseAvsQueue
+            [ AvsSyncCreationTime E.=. E.least    (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
+            , AvsSyncPause        E.=. E.greatest (current E.^. AvsSyncPause)        (excluded E.^. AvsSyncPause)
+            ]
+        )
+  runDBJobs' $ queueDBJob JobSynchroniseAvsQueue
+  return n
 
 
 -- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo;