diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 479b2009f..1c2a8943a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1006,56 +1006,42 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] handleFirmCommR ultDest cs = do - let csKey = CompanyKey <$> cs - -- get employees of chosen companies - empys <- E.unValue <<$>> runDB (E.select $ do - (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList csKey - return $ emp E.^. UserId - ) - -- get supervisors of employees - sprs <- E.unValue <<$>> runDB (E.select $ do - spr <- E.from $ E.table @User - E.where_ $ E.exists $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys - return $ spr E.^. UserId - ) - -- get companies of all supervisors - sprCmpys <- E.unValue <<$>> runDB (E.select $ do - cmpy <- E.from $ E.table @Company - E.where_ $ E.exists $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs - return $ cmpy E.^.CompanyId - ) let - queryLoners :: E.SqlQuery (E.SqlExpr (Entity User)) -- get supervisors without any company affiliation - queryLoners = do - spr <- E.from $ E.table @User - E.where_ $ spr E.^. UserId `E.in_` E.valList empys - E.&&. E.notExists (do - sprCmp <- E.from $ E.table @UserCompany - E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId - ) - return spr - - queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) - queryCmpy sORe acid = do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid - E.&&. (if sORe - then -- supervisors only - E.exists $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys - else E.true - ) + queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds + queryGiven usrs = do + usr <- E.from $ E.table @User + E.where_ $ usr E.^. UserId `E.in_` E.valList usrs return usr - + mkCompanyUsrList :: [(E.Value (Maybe CompanyId), E.Value UserId)] -> Map.Map (Maybe CompanyId) [UserId] + mkCompanyUsrList l = Map.fromAscListWith (++) [(c,[u]) | (E.Value c, E.Value u) <- l] + toGrp = maybe RGFirmIndependent (RGFirmSupervisor . unCompanyKey) + csKeys = CompanyKey <$> cs + mbUser <- maybeAuthId + -- get employees of chosen companies + empys <- mkCompanyUsrList <$> runDB (E.select $ do + (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser) + E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys + E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany] + return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) + ) + -- get supervisors of employees + --sprs <- mkCompanyUsrList <$> runDB (E.select $ do + sprs' <- runDB (E.select $ do + (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) + E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) + E.||. (spr E.^. UserId E.=?. E.val mbUser) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList (concat $ Map.elems empys) + ) + E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] + return (cmp E.?. UserCompanyCompany, spr E.^. UserId) + ) + $logInfoS "Firm" "!!!Messaging here!!!" + unless (checkAsc (fst <$> sprs')) ($logErrorS "Firm" ("Supervisor list isn't ascending!!!" <> tshow (fst <$> sprs'))) -- TODO: REMOVE THIS CHECK AND THE FOLLOWING LINE FOR PRODUCTION !!! + let sprs = mkCompanyUsrList sprs' + commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } @@ -1063,10 +1049,9 @@ handleFirmCommR ultDest cs = do , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult - , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] - [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- sprCmpys ] ++ - (RGFirmIndependent, queryLoners) : - [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ] + , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + [(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++ + [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ] } {- Auswahlbox für Mitteilung: diff --git a/src/Utils.hs b/src/Utils.hs index 44b863ae9..6ec20b881 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -771,6 +771,9 @@ pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a pattern NonEmpty x xs = x :| xs {-# COMPLETE NonEmpty #-} +checkAsc :: Ord a => [a] -> Bool +checkAsc (x:r@(y:_)) = x<=y && checkAsc r +checkAsc _ = True ---------- -- Sets --