diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d4a033e3f..456c2d983 100644 --- a/src/Handler/Firm.hs +++ b/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 - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - ) + E.where_ $ suprFltr spr + E.&&. spr E.^. UserSupervisorReason E.~=. E.val (tshow SupervisorReasonCompanyDefault) + E.&&. E.exists (do + 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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index f4045dd95..f4fec3cb9 100644 --- a/src/Handler/Utils/Avs.hs +++ b/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 diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 6414c1442..d51509f14 100644 --- a/src/Handler/Utils/Company.hs +++ b/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):(UserSupervisorUser <-. uids):reasonFilter) - where - reasonFilter = [UserSupervisorReason ==. Nothing] - ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] \ No newline at end of file + <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter) + <*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser <-. uids) : defaultSupervisorReasonFilter)