fix(firm): restrict firm access to company supervisors only

messages/uniworx/categories/firm/de-de-formal.msg

@@ -9,7 +9,7 @@ FirmEmail: Allgemeine Email
 FirmAddress: Postanschrift
 FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige
 FirmAction: Firmenweite Aktion
-FirmActionInfo: Betrifft alle Firmenangehörigen.
+FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
 FirmActNotify: Mitteilung versenden
 FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
 FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
@@ -18,7 +18,7 @@ FirmActAddSupersvisors: Ansprechpartner hinzufügen
 FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
 FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
 RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
-FirmActChangeContactUser: Kontaktinformationen von Firmenangehörigen ändern
+FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
 FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
 FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
 FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen

messages/uniworx/categories/firm/en-eu.msg

@@ -9,7 +9,7 @@ FirmEmail: General company email
 FirmAddress: Postal address
 FirmDefaultPreferenceInfo: Default setting for new company associates only
 FirmAction: Companywide action
-FirmActionInfo: Affects alle company associates.
+FirmActionInfo: Affects alle company associates under your supervision.
 FirmActNotify: Send message
 FirmActResetSupervision: Reset supervisors for all company associates
 FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
@@ -17,8 +17,8 @@ FirmActResetMutualSupervision: Supervisors supervise each other
 FirmActAddSupersvisors: Add supervisors
 FirmActAddSupersEmpty: No supervisors added
 FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
-RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)}
+RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
-FirmActChangeContactUser: Change contact data for company associates
+FirmActChangeContactUser: Change contact data for all company associates
 FirmActChangeContactFirm: Change company contact data
 FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
 FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only

src/Foundation/Authorization.hs

@@ -554,7 +554,8 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of
       return Authorized
     checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do
       authId <- maybeExceptT AuthenticationRequired $ return mAuthId      
-      isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh
+      -- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh
+      isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True]
       guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh)
       return Authorized
     checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do

src/Foundation/I18n.hs

@@ -273,7 +273,7 @@ newtype SomeMessages master = SomeMessages [SomeMessage master]
   deriving newtype (Semigroup, Monoid)
 
 instance master ~ master' => RenderMessage master (SomeMessages master') where
-  renderMessage a b (SomeMessages msgs) = Text.intercalate " " $ renderMessage a b <$> msgs
+  renderMessage a b (SomeMessages msgs) = Text.intercalate "\n " $ renderMessage a b <$> msgs
 
 -- | convenienience function if all messages happen to belong to the exact same type
 someMessages :: RenderMessage master msg => [msg] -> SomeMessages master

src/Handler/Firm.hs

@@ -113,23 +113,10 @@ firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (f
 makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId)
 makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts
 
-firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
+firmActionHandler :: Route UniWorX -> Bool -> FormResult (FirmActionData, Set CompanyId) -> Handler ()
-firmActionHandler route = flip formResult faHandler
+firmActionHandler route isAdmin = flip formResult faHandler
   where
     faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
-    faHandler (FirmActResetSupervisionData{..}, fids) = do
-      runDB $ do
-        delSupers <- if firmActResetKeepOldSupers == Just False
-          then E.deleteCount $ do
-                spr <- E.from $ E.table @UserSupervisor
-                E.where_ $ 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 <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids
-        addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
-      reloadKeepGetParams route -- reload to reflect changes
 
     faHandler (FirmActNotifyData, Set.toList -> fids) = do
       usrs <- runDB $ E.select $ E.distinct $ do
@@ -139,6 +126,26 @@ firmActionHandler route = flip formResult faHandler
       cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
       redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
 
+    faHandler (FirmActResetSupervisionData{..}, fids) = do
+      madId <- bool maybeAuthId (return Nothing) isAdmin
+      let suprFltr = if 
+            | isAdmin                 -> const E.true
+            | (Just suprId) <- madId  -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId
+            | otherwise               -> const E.false
+      runDB $ do
+        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
+                  )
+          else return 0
+        newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids
+        addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
+      reloadKeepGetParams route -- reload to reflect changes
+
     faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
       avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds
       let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
@@ -204,11 +211,12 @@ runFirmActionFormPost cid route isAdmin acts = do
                         , formSubmit = FormSubmit
                         , formAnchor = Just faAnchor
                         }
-  firmActionHandler route faRes
+  firmActionHandler route isAdmin faRes
   return [whamlet|
           <section>
             <h2 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
               _{MsgFirmAction}
+              $
             <div>
               <p>
                 _{MsgFirmActionInfo}
@@ -249,6 +257,30 @@ addDefaultSupervisors cid employees = do
     )
     (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications])
 
+-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual 
+addDefaultSupervisorsFor ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64
+addDefaultSupervisorsFor mbSuperId mutualSupervision cids = 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_ $ E.and $ guardMonoid (not mutualSupervision)
+                            [ E.not_ $ usr E.^. UserCompanySupervisor ]
+                        <>  maybeEmpty mbSuperId (\sprId -> [E.exists $ do 
+                              superv <- E.from $ E.table @UserSupervisor
+                              E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
+                                  E.&&.  superv E.^. UserSupervisorUser       E.==. usr E.^. UserCompanyUser
+                            ])
+                        <>  [          spr E.^. UserCompanySupervisor
+                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
+                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids                            
+                            ]
+      return $ UserSupervisor
+        E.<#  (spr E.^. UserCompanyUser)
+        E.<&> (usr E.^. UserCompanyUser)
+        E.<&> (spr E.^. UserCompanySupervisorReroute)
+    )
+    (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
+
 -- like `addDefaultSupervisors`, but selects all employees of given companies from database
 addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
 addDefaultSupervisorsAll mutualSupervision cids = do
@@ -621,7 +653,7 @@ postFirmAllR = do
   uid <- requireAuthId
   isAdmin <- checkAdmin
   (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
-  firmActionHandler FirmAllR firmRes
+  firmActionHandler FirmAllR isAdmin firmRes
   siteLayoutMsg MsgMenuFirms $ do
     setTitleI MsgMenuFirms
     $(i18nWidgetFile "firm-all")