refactor(firm): fix #157 refactor duplicated code

also ensures that supervisor default reaons filters are obeyed.

src/Handler/Firm.hs

@@ -149,11 +149,13 @@ firmActionHandler route isAdmin = flip formResult faHandler
         delSupers <- if firmActResetKeepOldSupers == Just False
           then E.deleteCount $ do
                 spr <- E.from $ E.table @UserSupervisor
-                E.where_ $ suprFltr spr E.&&. E.exists (do
+                E.where_ $ suprFltr spr
-                    usr <- E.from $ E.table @UserCompany
+                    E.&&. spr E.^. UserSupervisorReason E.~=. E.val (tshow SupervisorReasonCompanyDefault)
-                    E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
+                    E.&&. E.exists (do
-                        E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
+                      usr <- E.from $ E.table @UserCompany
-                  )
+                      E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids
+                          E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
+                    )
           else return 0
         newSupers <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids
         addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
@@ -252,25 +254,6 @@ runFirmActionFormPost cid route isAdmin acts = do
 -- Firm specific utilities
 -- for filters and counts also see before FirmAllR Handlers
 
-
-
--- | remove supervisors for given users; maybe restricted to those linked to a given companies
-deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64
-deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList usrs) : restrictByCompany
-  where
-    restrictByCompany = guardMonoid (notNull cids) [UserSupervisorCompany <-. (Just <$> cids)]
-
--- reset supervisors given employees of a company to default company supervision, deleting all previous company-related supervisors
-resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
-resetSupervisors cid employees = do
-  nr_del <- deleteSupervisors employees [cid]
-  let superReasonComDef = Just $ tshow SupervisorReasonCompanyDefault
-  nr_add <- addDefaultSupervisors superReasonComDef cid employees
-  return $ max nr_del nr_add
-
-
-
-------------------------------
 -- repeatedly useful queries
 
 usrPrimaryCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
@@ -1072,7 +1055,7 @@ postFirmUsersR fsh = do
     (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do  -- set guaranteed to be non-empty due to first case clause
       runDB $ do
         delSupers <- if firmUserActResetKeepOldSupers == Just False
-          then deleteSupervisors uids []
+          then deleteDefaultSupervisorsForUsers [] [] uids
           else return 0
         newSupers <- addDefaultSupervisors Nothing cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
@@ -1093,7 +1076,7 @@ postFirmUsersR fsh = do
               |]
         in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
       delSupers <- runDB
-         $ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep
+         $ bool (deleteDefaultSupervisorsForUsers [cid] [] uids) (return 0) firmUserActSetSuperKeep
         <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers]
       addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes

src/Handler/Utils/Avs.hs

@@ -439,7 +439,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
                   -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
                   -- deleteWhere $          (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
                   -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
-                  -- addDefaultSupervisors newCompanyId usrId
+                  -- addDefaultSupervisors' newCompanyId $ singleton usrId
                   -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
                   -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
                   -- return pst_up
@@ -553,7 +553,7 @@ createAvsUserById muid api = do
               let userComp = UserCompany uid cid False False 1 True Nothing -- 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
-              void $ addDefaultSupervisors Nothing cid $ singleton uid
+              void $ addDefaultSupervisors' cid $ singleton uid
               -- Save AVS data for future updates
               insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
               return uid

src/Handler/Utils/Company.hs

@@ -59,6 +59,11 @@ wgtCompanies = \uid -> do
           (accPri,accTop,accRem) = procCmp maxPri cs
       in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
 
+type AnySuperReason = Either SupervisorReason (Maybe Text)
+
+
+addDefaultSupervisors' :: CompanyId -> NonEmpty UserId -> DB Int64
+addDefaultSupervisors' = addDefaultSupervisors $ Just $ tshow SupervisorReasonCompanyDefault
 
 -- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
 -- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
@@ -211,13 +216,24 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
     newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
     superReasonComDef = tshow SupervisorReasonCompanyDefault
 
+defaultSupervisorReasonFilter :: [Filter UserSupervisor]
+defaultSupervisorReasonFilter =
+        [UserSupervisorReason  ==. Nothing]
+    ||. [UserSupervisorReason  ==. Just (tshow SupervisorReasonCompanyDefault)]
+--  ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]]
+
+-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
+deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
+deleteDefaultSupervisorsForUsers cids sprs usrs =
+    deleteWhereCount
+      $ bcons (notNull cids) (UserSupervisorCompany     <-. (cids <&> Just))
+      $ bcons (notNull sprs) (UserSupervisorSupervisor  <-.  sprs)
+      $ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
+
 -- | deletes user company association and all company related supervision
 -- WARNING: does not check for admin problems!
 deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64)
 deleteCompanyUser cid uids = (,,)
     <$> deleteWhereCount  [UserCompanyCompany    ==.      cid,  UserCompanyUser          <-. uids]
-    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids):reasonFilter)
+    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter)
-    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser       <-. uids):reasonFilter)
+    <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser       <-. uids) : defaultSupervisorReasonFilter)
-  where
-    reasonFilter = [UserSupervisorReason  ==. Nothing]
-               ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]]