refactor(firm): messaging performance

src/Handler/Firm.hs

@@ -1006,55 +1006,41 @@ 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
+  let 
+    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 <- E.unValue <<$>> runDB (E.select $ do 
+  empys <- mkCompanyUsrList <$> 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)
+      (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_ $ uc E.^. UserCompanyCompany `E.in_` E.valList csKey
+      E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys          
-      return $ emp E.^. UserId
+      E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
+      return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
     )
   -- get supervisors of employees  
-  sprs <- E.unValue <<$>> runDB (E.select $ do 
+  --sprs <- mkCompanyUsrList <$> runDB (E.select $ do 
-      spr <- E.from $ E.table @User
+  sprs' <- runDB (E.select $ do 
-      E.where_ $ E.exists $ do
+      (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
-        usrSpr <- E.from $ E.table @UserSupervisor
+      E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
-        E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId
+        E.||. (spr E.^. UserId E.=?. E.val mbUser)
-            E.&&.  usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys
+        E.||. E.exists (do
-      return $ spr E.^. UserId
+          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)
     )
-  -- get companies of all supervisors
+  $logInfoS "Firm" "!!!Messaging here!!!"
-  sprCmpys <- E.unValue <<$>> runDB (E.select $ do
+  unless (checkAsc (fst <$> sprs')) ($logErrorS "Firm" ("Supervisor list isn't ascending!!!" <> tshow (fst <$> sprs'))) -- TODO: REMOVE THIS CHECK AND THE FOLLOWING LINE FOR PRODUCTION !!!
-      cmpy <- E.from $ E.table @Company
+  let sprs = mkCompanyUsrList sprs'
-      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
-          )
-      return usr
     
   commR CommunicationRoute
     { crHeading   = SomeMessage $ case cs of { [c] -> MsgFirmNotification      c ; _ -> MsgFirmsNotification }
@@ -1064,9 +1050,8 @@ handleFirmCommR ultDest cs = do
     , 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 ] ++
+      [(toGrp acid, queryGiven usrs) | (acid, usrs)  <- Map.toAscList sprs ] ++
-       (RGFirmIndependent, queryLoners) :
+      [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs)  | (Just acid, usrs) <- Map.toAscList empys ]
-      [(RGFirmEmployees  $ unCompanyKey acid, queryCmpy False acid)  | acid <- csKey ]
     }
 
   {- Auswahlbox für Mitteilung:

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 --