chore(avs): proper company superiors as company wide default APs (WIP)

models/users.model

@@ -91,7 +91,7 @@ UserCompany
     company               CompanyId  OnDeleteCascade OnUpdateCascade
     supervisor            Bool       default=false -- should this user be made supervisor for all _new_ users associated with this company?        
     supervisorReroute     Bool       default=false -- if supervisor is true, should this supervisor receive email for _new_ company users?
-    priority              Int        default=0     -- higher number, higher priority
+    priority              Int        default=0     -- higher number, higher priority; default=1 for Haskell-Code
     useCompanyAddress     Bool       default=true  -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority
     UniqueUserCompany user company   -- a user may belong to multiple companies, but to each one only once
     deriving Generic Show

src/Handler/Utils/Avs.hs

@@ -444,7 +444,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                   -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
                   -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
                   -- return pst_up 
-        repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId        -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors                
+        repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId        -- ensure firmInfo superior is supervisor, must be executed after updating company default supervisors
         update usrId $ usr_up2 <> usr_up1                                         -- update user eventually
         update uaId    avs_ups                                                    -- update stored avsinfo for future updates
       return (apid, usrId)
@@ -570,9 +570,50 @@ repsertSuperiorSupervisor cid afi uid =
           (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)            
     ) $ \supid -> do
       let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
-      deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior]
+          newSupervisor  = UserSupervisor supid uid False cid reasonSuperior
-      void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior
+      deleteWhere [UserSupervisorUser ==. uid, UserSupervisorSupervisor !=. supid, UserSupervisorReason ==. reasonSuperior] -- delete previous superiors, if any
+      -- void $ upsertBy (UniqueUserSupervisor supid uid) newSupervisor [company =. cid, reason =. reasonSuperior]          -- always update supervisor reason
+      void $ insertUnique $ UserSupervisor supid uid False cid reasonSuperior                                               -- do not change existing supervisor relationship
 
+-- TODO: CR3: user upsertCompanySuperior instead of repsertSuperiorSupervisor
+-- upsert company supervisor from AvsFirmEMailSuperior
+upsertCompanySuperior :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB (Maybe (CompanyId, UserId))
+upsertCompanySuperior newAfi mbOldAfi = runMaybeT $ do
+    supemail <- MaybeT . pure $ newAfi ^. _avsFirmEMailSuperior
+    supid <- MaybeT $ altM (guessUserByEmail $ stripCI supemail)
+                           (catchAVShandler True True False Nothing $ Just . entityKey <$> ldapLookupAndUpsert supemail)
+    cid <- MaybeT $ getAvsCompanyId newAfi    
+    lift $ do 
+      void $ runMaybeT $ do -- remove old superior, if any
+        oldAfi  <- MaybeT $ pure mbOldAfi
+        oldSeml <- MaybeT $ pure $ oldAfi ^. _avsFirmEMailSuperior
+        oldSup  <- MaybeT $ guessUserByEmail $ stripCI oldSeml
+        oldCid  <- MaybeT $ getAvsCompanyId oldAfi
+        when (oldCid == cid && oldSup /= supid) $ lift $ do
+          let reasonSuperior = Just $ tshow SupervisorReasonAvsSuperior
+          deleteWhere [UserCompanyCompany ==. cid, UserCompanyUser ==. oldSup] -- remove old supervisor from company
+          -- switch supervison
+          -- updateWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] [UserSupervisor =. supid] -- not safe, could violate uniqueness
+          E.update $ \usuper -> do
+            E.set usuper [ UserSupervisorSupervisor E.=. E.val supid ]
+            E.where_ $ usuper E.^. UserSupervisorSupervisor E.==. E.val oldSup
+                E.&&.  usuper E.^. UserSupervisorCompany    E.==. E.justVal cid
+                E.&&.  usuper E.^. UserSupervisorReason     E.==. E.val reasonSuperior
+                E.&&. E.notExists (do
+                    newSuper <- E.from $ E.table @UserSupervisor
+                    E.where_ $ newSuper E.^. UserSupervisorSupervisor E.==. E.val supid
+                        E.&&.  newSuper E.^. UserSupervisorUser       E.==. newSuper E.^. UserSupervisorUser
+                  )
+          deleteWhere [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor ==. oldSup, UserSupervisorReason ==. reasonSuperior] -- remove un-updateable remainders, if any          
+      -- upsert new superior company supervisor
+      void $ upsertBy (UniqueUserCompany supid cid)
+                            (UserCompany supid cid True False 1 True)
+                            [UserCompanySupervisor =. True]
+      return (cid,supid)
+
+
+getAvsCompanyId :: AvsFirmInfo -> DB (Maybe CompanyId)
+getAvsCompanyId = fmap (fmap entityKey) . getAvsCompany
 
 -- | 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))