diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 7ad115f43..dc46d5f9a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -28,11 +28,11 @@ import qualified Data.Map as Map -- import qualified Data.Text as T import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C --- import Database.Persist.Sql (updateWhereCount) +import Database.Persist.Sql (deleteWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as EL (from, on) --- import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -42,6 +42,56 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton +--------------------------- +-- Firm specific utilities +-- for filters and counts see before FirmAllR Handlers + +-- remove supervisors: +deleteSupervisors :: NonEmpty UserId -> DB Int64 +deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs] + +-- reset supervisors given employees of a company to default company supervision, deleting all other supervisors +resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 +resetSupervisors cid employees = do + nr_del <- deleteSupervisors employees + nr_add <- addDefaultSupervisors cid employees + return $ max nr_del nr_add + +-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company +addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 +addDefaultSupervisors cid employees = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanySupervisor + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> usr + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + +-- like `addDefaultSupervisors`, but selects all employees from database +addDefaultSupervisorsAll :: CompanyId -> DB Int64 +addDefaultSupervisorsAll cid = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanySupervisor + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + + + +------------------ +-- Debug Handler + getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do