fix(firm): fix #157 by removing redundant duplicated code in firm user and supervision handling

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

@@ -27,11 +27,16 @@ FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft n
 FirmUserActNotify: Mitteilung versenden
 FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
 FirmUserActSetSupervisor: Ansprechpartner ändern
+FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
+FirmUserActChangeDetails: Firmenassoziation bearbeiten
+FirmUserActRemove: Firmenassoziation entfernen
+FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
+FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
+FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
+FirmuserActRemoveResult uc@Int64 sup@Int64 sub@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. #{noneMoreDE sup "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöschtt. ")} #{noneMoreDE sub "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entfernten Angesprochenen gelöscht.")}
 FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
 FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
 FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
-FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
-FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
 FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
 FirmSuperActNotify: Mitteilung versenden
 FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
@@ -57,5 +62,9 @@ TableIsDefaultSupervisor: Standardansprechpartner
 TableIsDefaultReroute: Standardumleitung
 FormFieldPostal: Benachrichtigungseinstellung
 FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
-FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
+FirmSupervisionKeyData: Kennzahlen Ansprechpartner
-FirmSupervisionKeyData: Kennzahlen Ansprechpartner
+CompanyUserPriority: Firmenpriorität
+CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person
+CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse
+CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist
+CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!

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

@@ -27,15 +27,20 @@ FirmActChangeContactFirmResult: Company contact data changed, affecting future c
 FirmUserActNotify: Send message
 FirmUserActResetSupervision: Reset supervisors to company default
 FirmUserActSetSupervisor: Change supervision
+FirmUserActChangeContact: Change contact data for selected company associates
+FirmUserActChangeDetails: Edit company association
+FirmUserActRemove: Delete company association
+FirmUserActMkSuper: Mark as company supervisor
+FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
+FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
+FirmuserActRemoveResult uc sup sub: #{pluralENsN uc "Company association"} deleted. #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "" ((pluralENsN sub "supervision") <> " removed due to eliminated supervisees.")}
 FirmNewSupervisor: Appoint new individual supervisors
 FirmSetSupervisor: Add existing supervisors
-FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
+FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
 FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
-FirmUserActChangeContact: Change contact data for selected company associates
-FirmUserActMkSuper: Mark as company supervisor
 FirmSuperActNotify: Send message
 FirmSuperActSwitchSuper: Change default company supervisor
-FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired.
+FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired.
 FirmSuperActRMSuperDef: Remove default supervisor
 FirmSuperActRMSuperActive: Also remove active supervisions within this company
 FirmsNotification: Send company notification e-mail
@@ -57,5 +62,9 @@ TableIsDefaultSupervisor: Default supervisor
 TableIsDefaultReroute: Default reroute
 FormFieldPostal: Notification type
 FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
-FirmUserChanges n: Notification settings changed for #{n} company associates
+FirmSupervisionKeyData: Supervision key data
-FirmSupervisionKeyData: Supervision key data
+CompanyUserPriority: Company priority
+CompanyUserPriorityTip: Company priority is relative to other company associations for a user
+CompanyUserUseCompanyAddress: Use company postal address
+CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty
+CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!

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

@@ -12,7 +12,7 @@ QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E
 QualificationAuditDurationReuseError: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde.
 QualificationRefreshWithin: Erneurerungszeitraum
 QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
-QualificationRefreshReminder: 2. Erinnerung
+QualificationRefreshReminder: Zweite Erinnerung
 QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde.
 QualificationElearningStart: Wird das E‑Learning automatisch gestartet?
 QualificationElearningRenew: Verlängert ein erfolgreiches E‑Learning die Qualifikation automatisch um die reguläre Gültigkeitsdauer?

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

@@ -12,7 +12,7 @@ QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑lea
 QualificationAuditDurationReuseError: This qualification reuses the e‑learning from another qualification, which has no audit duration configured.
 QualificationRefreshWithin: Refresh within
 QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
-QualificationRefreshReminder: 2. Reminder
+QualificationRefreshReminder: Second reminder
 QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry.
 QualificationElearningStart: Is e‑learning automatically started?
 QualificationElearningRenew: Does successful e‑learning automatically extend a qualification by the default validity period?

messages/uniworx/misc/de-de-formal.msg

@@ -26,4 +26,6 @@ AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht m
 
 PaginationSize: Einträge pro Seite
 PaginationPage: Angzeigte Seite
-PaginationError: Paginierung Parameter dürfen nicht negativ sein
+PaginationError: Paginierung Parameter dürfen nicht negativ sein
+
+NullDeletes: Zum Löschen NULL eingeben.

messages/uniworx/misc/en-eu.msg

@@ -26,4 +26,6 @@ AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving
 
 PaginationSize: Rows per Page
 PaginationPage: Page to show
-PaginationError: Pagination parameter must not be negative
+PaginationError: Pagination parameter must not be negative
+
+NullDeletes:  Enter NULL to delete.

src/Handler/Firm.hs

@@ -19,6 +19,7 @@ import Import
 
 -- import Jobs
 import Handler.Utils
+import Handler.Utils.Company
 import Handler.Utils.Communication
 import Handler.Utils.Avs (guessAvsUser)
 
@@ -32,8 +33,8 @@ import qualified Data.CaseInsensitive as CI
 import Database.Persist.Postgresql
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-import qualified Database.Esqueleto.Legacy as EL (on)
+import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable
-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
 
@@ -83,6 +84,7 @@ data FirmActionData = FirmActNotifyData
                         }
                     | FirmActChangeContactUserData
                         { firmActCCUPostalAddr            :: Maybe StoredMarkup
+                        , firmActCCUUseCompanyPostal      :: Maybe Bool
                         , firmActCCUPostalPref            :: Maybe Bool
                         }
   deriving (Eq, Ord, Read, Show, Generic)
@@ -92,8 +94,8 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
   where
     mkAct True  FirmActNotify           = singletonMap FirmActNotify           $ pure FirmActNotifyData
     mkAct _     FirmActResetSupervision = singletonMap FirmActResetSupervision $      FirmActResetSupervisionData
-                  <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
+                  <$> aopt boolField'                       (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
-                  <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
+                  <*> aopt checkBoxField                    (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
     mkAct _     FirmActAddSupervisors   = singletonMap FirmActAddSupervisors   $ FirmActAddSupervisorsData
                   <$> areq (textField & cfAnySeparatedSet)  (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
                   <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute)                                                             (Just True)
@@ -103,10 +105,11 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
     mkAct _     FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
                   <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
                   <*> aopt (emailField & cfStrip & cfCI)    (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
-                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip)   Nothing
+                  <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFirmDefaultPreferenceInfo)   Nothing
                   <*  aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
     mkAct _     FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
                   <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
+                  <*> aopt boolField'                       (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
     mkAct _  _ = mempty
     ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text)
@@ -152,7 +155,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
                         E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
                   )
           else return 0
-        newSupers <- addDefaultSupervisorsFor Nothing madId (firmActResetMutualSupervision /= Just False) fids
+        newSupers <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids
         addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams route -- reload to reflect changes
 
@@ -191,21 +194,30 @@ firmActionHandler route isAdmin = flip formResult faHandler
         addMessageI Success MsgFirmActChangeContactFirmResult
         reloadKeepGetParams route
 
-    faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) =
+    faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid])
-      let changes = catMaybes
+      | firmActCCUUseCompanyPostal == Just True, isJust firmActCCUPostalAddr =
-            [ (UserPostAddress   E.=.) . E.justVal <$> canonical firmActCCUPostalAddr  -- note that Nothing means no change and not delete address!
+          addMessageI Error MsgCompanyUserUseCompanyPostalError
-            , (UserPrefersPostal E.=.) . E.val     <$>           firmActCCUPostalPref
+      | otherwise = do
-            ]
+          let changes = catMaybes
-      in unless (null changes) $ do
+                [ toMaybe (firmActCCUUseCompanyPostal == Just True) (UserPostAddress   E.=. E.nothing)      -- precondition ensures that only one update applies for UserPostAddress
-        nrChanged <- runDB $ E.updateCount $ \usr -> do
+                , (UserPostAddress   E.=.) . E.justVal <$> canonical firmActCCUPostalAddr  -- note that Nothing means no change and not delete address!
-          E.set usr changes
+                , (UserPrefersPostal E.=.) . E.val     <$>           firmActCCUPostalPref
-          E.where_ $ E.exists $ do
+                ]
-            usrCmpy <- E.from $ E.table @UserCompany
+          (total, nrChanged) <- runDB $ do
-            E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
+            nrUsrChange <- E.updateCount $ \usr -> do
-                E.&&.  usrCmpy E.^. UserCompanyUser    E.==. usr E.^. UserId
+              E.set usr changes
-        addMessageI Success $ MsgFirmUserChanges nrChanged
+              E.where_ $ E.exists $ do
-        reloadKeepGetParams route  -- reload to reflect changes
+                usrCmpy <- E.from $ E.table @UserCompany
-
+                E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
+                    E.&&.  usrCmpy E.^. UserCompanyUser    E.==. usr E.^. UserId
+            nrUseComp <- case firmActCCUUseCompanyPostal of
+              Just x  -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x]
+              Nothing -> return 0
+            nrCid <- count [UserCompanyCompany ==. cid]
+            return (fromIntegral nrCid, max nrUsrChange nrUseComp)
+          let allok = bool Warning Success $ nrChanged == total
+          addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
+          reloadKeepGetParams route  -- reload to reflect changes
     faHandler _ = addMessageI Error MsgErrorUnknownFormAction
 
 
@@ -256,81 +268,6 @@ resetSupervisors cid employees = do
   nr_add <- addDefaultSupervisors superReasonComDef 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 :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
-addDefaultSupervisors reason 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
-      E.distinct $ return $ UserSupervisor
-        E.<#  (spr E.^. UserCompanyUser)
-        E.<&>  usr
-        E.<&> (spr E.^. UserCompanySupervisorReroute)
-        E.<&> E.justVal cid
-        E.<&> E.val reason
-    )
-    (\old new ->
-      [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-      , UserSupervisorCompany E.=. E.justVal cid
-      , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
-      ])
-
--- 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 Text -> Maybe UserId -> Bool -> mono -> DB Int64
-addDefaultSupervisorsFor reason 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
-                            ]
-      E.distinct $ return $ UserSupervisor
-        E.<#  (spr E.^. UserCompanyUser)
-        E.<&> (usr E.^. UserCompanyUser)
-        E.<&> (spr E.^. UserCompanySupervisorReroute)
-        E.<&> E.just (spr E.^. UserCompanyCompany)
-        E.<&> E.val reason
-    )
-    (\old new ->
-        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-        , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
-        ] )
-
--- like `addDefaultSupervisors`, but selects all employees of given companies from database
-addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
-addDefaultSupervisorsAll reason 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 ]
-                        <>  [          spr E.^. UserCompanySupervisor
-                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
-                            ]
-      E.distinct $ return $ UserSupervisor
-        E.<#  (spr E.^. UserCompanyUser)
-        E.<&> (usr E.^. UserCompanyUser)
-        E.<&> (spr E.^. UserCompanySupervisorReroute)
-        E.<&> E.just (spr E.^. UserCompanyCompany)
-        E.<&> E.val reason
-    )
-    (\old new ->
-        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
-        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-        , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
-        ] )
 
 
 ------------------------------
@@ -808,7 +745,9 @@ data FirmUserAction = FirmUserActNotify
                     | FirmUserActResetSupervision
                     | FirmUserActSetSupervisor
                     | FirmUserActMkSuper
+                    | FirmUserActChangeDetails
                     | FirmUserActChangeContact
+                    | FirmUserActRemove
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -829,9 +768,17 @@ data FirmUserActionData = FirmUserActNotifyData
                             }
                         | FirmUserActMkSuperData
                             { firmUserActMkSuperReroute   :: Maybe Bool }
+                        | FirmUserActChangeDetailsData
+                            { firmUserActDetailPriority     :: Maybe Int
+                            , firmUserActDetailReason       :: Maybe Text
+                            }
                         | FirmUserActChangeContactData
-                            { firmUserActPostalAddr :: Maybe StoredMarkup
+                            { firmUserActPostalAddr         :: Maybe StoredMarkup
-                            , firmUserActPostalPref :: Maybe Bool
+                            , firmUserActUseCompanyPostal   :: Maybe Bool
+                            , firmUserActPostalPref         :: Maybe Bool
+                            }
+                        | FirmUserActRemoveData
+                            { firmUserActRemoveKeepSuper :: Bool
                             }
   deriving (Eq, Ord, Show, Generic)
 
@@ -843,7 +790,7 @@ queryUserUser = $(sqlIJproj 2 1)
 queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
 queryUserUserCompany = $(sqlIJproj 2 2)
 
-type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) -- , E.Value Bool)
+type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64, E.Value Bool)
 
 resultUserUser :: Lens' UserCompanyTableData (Entity User)
 resultUserUser = _dbrOutput . _1
@@ -857,8 +804,8 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
 resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
 
--- resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
+resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
--- resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
+resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
 
 instance HasEntity UserCompanyTableData User where
   hasEntity = resultUserUser
@@ -900,12 +847,12 @@ mkFirmUserTable isAdmin cid = do
         dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
           EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
           E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
-          -- let isPrimary = E.notExists (do
+          let isPrimary = E.notExists (do
-          --         other <- E.from $ E.table @UserCompany
+                  other <- E.from $ E.table @UserCompany
-          --         E.where_ $ other E.^. UserCompanyUser     E.==. usrCmp E.^. UserCompanyUser
+                  E.where_ $ other E.^. UserCompanyUser     E.==. usrCmp E.^. UserCompanyUser
-          --             E.&&.  other E.^. UserCompanyPriority E.>.  usrCmp E.^. UserCompanyPriority
+                      E.&&.  other E.^. UserCompanyPriority E.>.  usrCmp E.^. UserCompanyPriority
-          --         )
+                  )
-          return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
+          return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp, isPrimary)
         dbtRowKey = queryUserUser >>> (E.^. UserId)
         dbtProj = dbtProjId
         dbtColonnade = formColonnade $ mconcat
@@ -916,8 +863,16 @@ mkFirmUserTable isAdmin cid = do
           , sortable (Just "supervisors")     (i18nCell MsgTableCompanyNrSupers       )  $ \(view resultUserCompanySupervisors  -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "reroutes")        (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view resultUserCompanyReroutes     -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "postal-pref")     (i18nCell MsgPrefersPostal)                $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+          , sortable Nothing                  (i18nCell MsgCompanyUserUseCompanyAddress) $ \row ->
+              let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress
+                  useCompA  = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress
+              in tickmarkCell $ noUsrAddr && useCompA
           , colUserEmail
           , sortable (Just "usr-reason")      (i18nCell MsgTableCompanyReason)           $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r
+          , sortable (Just "priority")        (i18nCell MsgCompanyUserPriority)          $ \row ->
+              let prio :: Int = row ^. resultUserUserCompany . _entityVal . _userCompanyPriority
+                  isPrime     = row ^. resultUserCompanyPrimary
+              in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
           ]
         dbtSorting = mconcat
@@ -929,6 +884,7 @@ mkFirmUserTable isAdmin cid = do
           , singletonMap "supervisors"      $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
           , singletonMap "reroutes"         $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
           , singletonMap "usr-reason"       $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)
+          , singletonMap "priority"         $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority)
           ]
         dbtFilter = mconcat
           [ single $ fltrUserNameEmail queryUserUser
@@ -1005,6 +961,13 @@ mkFirmUserTable isAdmin cid = do
           , prismAForm (singletonFilter "is-primary-company"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI   MsgFilterFirmPrimary)
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+        userReasons :: HandlerFor UniWorX (OptionList Text)
+        userReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+          fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
+            usrc <- E.from $ E.table @UserCompany
+            E.where_ $ E.isJust (usrc E.^. UserCompanyReason)
+                  E.&&. usrc E.^. UserCompanyCompany E.==. E.val cid
+            return $ usrc E.^. UserCompanyReason
         superReasons :: HandlerFor UniWorX (OptionList Text)
         superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
           fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
@@ -1026,9 +989,15 @@ mkFirmUserTable isAdmin cid = do
               <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
           , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
               <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
+          , singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
+              <$> aopt intField                                           (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
+              <*> aopt (textField & cfStrip & addDatalist userReasons)    (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
           , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
-              <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
+              <$> aopt htmlField        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
-              <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
+              <*> aopt boolField'       (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
+              <*> aopt postalEmailField (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
+          , singletonMap FirmUserActRemove $ FirmUserActRemoveData
+              <$> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
           ]
         dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
@@ -1128,20 +1097,45 @@ postFirmUsersR fsh = do
         <* 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
-
     (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
-      nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
+      nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
-      addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
+      addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
-    (FirmUserActChangeContactData{..}, Set.toList -> uids) ->
+    (FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do
-      let changes = catMaybes
+      let upReason = case canonical firmUserActDetailReason of
-            [ (UserPostAddress   =.) . Just <$> canonical firmUserActPostalAddr  -- note that Nothing means no change and not delete address!
+                      Nothing     -> Nothing
-            , (UserPrefersPostal =.)        <$>           firmUserActPostalPref
+                      Just "NULL" -> Just $ UserCompanyReason =. Nothing
-            ]
+                      other       -> Just $ UserCompanyReason =. other
-      in unless (null changes) $ do
+      nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
-        nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes
+      let total = fromIntegral $ length uids
-        addMessageI Success $ MsgFirmUserChanges nrChanged
+          allok = bool Warning Success $ nrUpd == total
+      addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total
+      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
+    (FirmUserActChangeContactData{..}, Set.toList -> uids)
+      | firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
+          addMessageI Error MsgCompanyUserUseCompanyPostalError
+      | otherwise -> do
+        let changes = catMaybes
+              [ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress
+              , (UserPostAddress   =.) . Just <$> canonical firmUserActPostalAddr               -- note that Nothing means no change and not delete address!
+              , (UserPrefersPostal =.)        <$>           firmUserActPostalPref
+              ]
+        nrChanged <- runDB $ do
+          nrUsrChange <- updateWhereCount [UserId <-. uids] changes
+          nrUseComp   <- case firmUserActUseCompanyPostal of
+            Just x  -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x]
+            Nothing -> return 0
+          return $ max nrUsrChange nrUseComp
+        let total = fromIntegral $ length uids
+            allok = bool Warning Success $ nrChanged == total
+        addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
         reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
+    (FirmUserActRemoveData{}, Set.toList -> uids) -> do
+      (nrUc, nrSuper, nrSubs) <- runDB $ deleteCompanyUser cid uids
+      let total = fromIntegral $ length uids
+          allok = bool Warning Success $ nrUc == total
+      addMessageI allok $ MsgFirmuserActRemoveResult nrUc nrSuper nrSubs
+      reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
   formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
 

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
-                  -- addCompanySupervisors newCompanyId usrId
+                  -- addDefaultSupervisors newCompanyId 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
-              addCompanySupervisors cid uid
+              void $ addDefaultSupervisors Nothing 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

src/Handler/Utils/Company.hs

@@ -21,6 +21,14 @@ import qualified Database.Esqueleto.PostgreSQL   as E
 import Handler.Utils.Users
 import Handler.Utils.Widgets
 
+-- Snippet to restrict to primary company only
+--  E.&&. E.notExists (do
+--      othr <- E.from $ E.table @UserCompany
+--      E.where_ $ othr E.^. UserCompanyPriority E.>.  userCompany E.^. UserCompanyPriority
+--          E.&&.  othr E.^. UserCompanyUser     E.==. userCompany E.^. UserCompanyUser
+--          E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
+--    )
+
 company2msg :: CompanyId -> SomeMessage UniWorX
 company2msg = text2message . ciOriginal . unCompanyKey
 
@@ -51,38 +59,90 @@ 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!
 
--- TODO: use this function in company view Handler.Firm #157
--- | add all company supervisors for a given users
-addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
-                      => Key Company -> Key User -> ReaderT backend m ()
-addCompanySupervisors cid uid =
-  E.insertSelectWithConflict
-    UniqueUserSupervisor
-    ( do
-        userCompany <- E.from $ E.table @UserCompany
-        E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
-            E.&&.  userCompany E.^. UserCompanySupervisor
-        --  E.&&. E.notExists (do                                                              -- restrict to primary company only
-        --      othr <- E.from $ E.table @UserCompany
-        --      E.where_ $ othr E.^. UserCompanyPriority E.>.  userCompany E.^. UserCompanyPriority
-        --          E.&&.  othr E.^. UserCompanyUser     E.==. userCompany E.^. UserCompanyUser
-        --          E.&&.  othr E.^. UserCompanyCompany  E.!=. E.val cid                       -- redundant due to > above, but likely performance improving
-        --    )
 
-        return $ UserSupervisor
+-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
-          E.<#  (userCompany E.^. UserCompanyUser)
+-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
-          E.<&>  E.val uid
+addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
-          E.<&> (userCompany E.^. UserCompanySupervisorReroute)
+addDefaultSupervisors reason cid employees = do
-          E.<&>  E.justVal cid
+  E.insertSelectWithConflictCount UniqueUserSupervisor
-          E.<&>  E.justVal (tshow SupervisorReasonCompanyDefault)
+    (do
-    )
+      (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
-    (\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
+      E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
-        [ UserSupervisorCompany E.=. E.coalesce [current  E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
+          E.&&.  spr E.^. UserCompanySupervisor
-        , UserSupervisorReason  E.=. E.coalesce [current  E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
+      E.distinct $ return $ UserSupervisor
-        ]
+        E.<#  (spr E.^. UserCompanyUser)
+        E.<&>  usr
+        E.<&> (spr E.^. UserCompanySupervisorReroute)
+        E.<&> E.justVal cid
+        E.<&> case reason of
+                Nothing     -> E.justVal $ tshow SupervisorReasonCompanyDefault
+                Just "NULL" -> E.nothing
+                other       -> E.val other
     )
+    (\old new ->
+      [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
+      , UserSupervisorCompany E.=. E.justVal cid
+      , UserSupervisorReason  E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
+      ])
 
 
+-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
+-- TODO: check redundancies
+addDefaultSupervisorsFor ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
+addDefaultSupervisorsFor reason 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
+                            ]
+      E.distinct $ return $ UserSupervisor
+        E.<#  (spr E.^. UserCompanyUser)
+        E.<&> (usr E.^. UserCompanyUser)
+        E.<&> (spr E.^. UserCompanySupervisorReroute)
+        E.<&> E.just (spr E.^. UserCompanyCompany)
+        E.<&> E.val reason
+    )
+    (\old new ->
+        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
+        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
+        , UserSupervisorReason  E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
+        ] )
+
+-- like `addDefaultSupervisors`, but selects all employees of given companies from database
+-- TODO: check redundancies
+addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
+addDefaultSupervisorsAll reason 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 ]
+                        <>  [          spr E.^. UserCompanySupervisor
+                            , spr E.^. UserCompanyCompany `E.in_` E.vals cids
+                            , usr E.^. UserCompanyCompany `E.in_` E.vals cids
+                            ]
+      E.distinct $ return $ UserSupervisor
+        E.<#  (spr E.^. UserCompanyUser)
+        E.<&> (usr E.^. UserCompanyUser)
+        E.<&> (spr E.^. UserCompanySupervisorReroute)
+        E.<&> E.just (spr E.^. UserCompanyCompany)
+        E.<&> E.val reason
+    )
+    (\old new ->
+        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
+        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
+        , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
+        ] )
+
 -- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
 switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
 switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
@@ -108,7 +168,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
     case mbUsrComp of
       Nothing -> do -- create company user
         void $ insertUnique newUserComp
-        addCompanySupervisors newCompanyId uid
+        void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
         return (usrUpdate, mempty)
       Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
         | newCompanyId == oldCompanyId -> return mempty -- nothing to do
@@ -140,7 +200,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
             oldAPs <- if keepOldCompanySupervs
               then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
               else deleteWhereCount oldSubFltr
-            addCompanySupervisors newCompanyId uid
+            void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
             newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
             let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
                 problems = bcons oldSuper             (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
@@ -149,4 +209,15 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
             return (usrUpdate ,problems)
   where
     newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
-    superReasonComDef = tshow SupervisorReasonCompanyDefault
+    superReasonComDef = tshow SupervisorReasonCompanyDefault
+
+-- | 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]]]

src/Handler/Utils/Form.hs

@@ -77,7 +77,7 @@ import qualified Data.Text.Lazy.Builder as Builder
 -- import Control.Monad.Catch.Pure (runCatch)
 
 import qualified Data.List.NonEmpty as NonEmpty
-  
+
 {-# ANN module ("HLint: ignore Use const" :: String) #-}
 
 
@@ -217,7 +217,7 @@ optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do
   let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews'
 
   return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews)
-           
+
 optionalAction :: AForm Handler a
                -> FieldSettings UniWorX
                -> Maybe Bool
@@ -236,7 +236,7 @@ optionalActionA :: AForm Handler a
                 -> Maybe Bool
                 -> AForm Handler (Maybe a)
 optionalActionA = optionalActionA' mpopt
-  
+
 optionalActionNegatedA :: AForm Handler a
                        -> FieldSettings UniWorX
                        -> Maybe Bool
@@ -740,8 +740,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
                 let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
                  in pure $ Map.singleton iStart fileRes
           return (addRes', formWidget')
-        miCell _ initFile _ nudge csrf =
+        miCell _ initFile _ nudge = sFileForm nudge (Just initFile)
-          sFileForm nudge (Just initFile) csrf
         miDelete :: MassInputDelete ListLength
         miDelete = miDeleteList
         miAddEmpty _ _ _ = Set.empty
@@ -966,9 +965,9 @@ genericFileField mkOpts = Field{..}
       $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles
       $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
       return $ mconcat
-        [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap 
+        [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
         , sessionFiles'
-        , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap 
+        , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
         ]
 
     handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) ()
@@ -1002,7 +1001,7 @@ genericFileField mkOpts = Field{..}
     fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
     fieldParse vals files' = runExceptT $ do
       let files = filter (not . null . fileName) files'
-      
+
       opts@FileField{..} <- liftHandler mkOpts
 
       mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
@@ -1116,7 +1115,7 @@ genericFileField mkOpts = Field{..}
                   fuiChecked
                     | Right sentVals' <- sentVals
                     = fuiTitle `Set.member` sentVals'
-                    | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap 
+                    | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
                     = fieldOptionDefault
                     | otherwise = False
                   fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles
@@ -1201,7 +1200,7 @@ zipFileField :: Bool -- ^ Unpack zips?
               -> Bool -- ^ Empty files ok?
               -> Field Handler FileUploads
 zipFileField doUnpack permittedExtensions emptyOk = zipFileField' doUnpack permittedExtensions emptyOk Nothing
-  
+
 zipFileField' :: Bool -- ^ Unpack zips?
               -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
               -> Bool -- ^ Empty files ok?
@@ -1315,16 +1314,16 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
 
     editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) ->
       hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
-  
+
     return (examParts'', editableExams)
 
   let
     examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt)
     examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber)
-    
+
     doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints'
                     || not (null examParts)
-    
+
     acts = Map.fromList $ catMaybes
       [ pure ( Normal', Normal <$> gradingReq )
       , pure ( Bonus' , Bonus  <$> gradingReq )
@@ -1346,7 +1345,7 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
       Informational' -> return $ i18n MsgSheetTypeInfoInformational
       NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded
       ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints
-  
+
   aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
@@ -1468,7 +1467,7 @@ jsonField fieldKind = Field{..}
 {- was only used in workflows; if needed recreate MsgYAMLFieldDecodeFailure
 yamlField :: ( ToJSON a, FromJSON a
              , MonadHandler m
-             , RenderMessage (HandlerSite m) FormMessage             
+             , RenderMessage (HandlerSite m) FormMessage
              )
           => Field m a
 yamlField = Field{..}
@@ -1483,7 +1482,14 @@ yamlField = Field{..}
           #{either id (decodeUtf8 . Yaml.encode) val}
       |]
     fieldEnctype = UrlEncoded
--}   
+-}
+
+
+boolField' :: ( MonadHandler m
+              , HandlerSite m ~ UniWorX
+              )
+          => Field m Bool
+boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant)
 
 boolField :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
@@ -2309,7 +2315,7 @@ examModeForm mPrev = examMode
   <*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev)
   where
     examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
-    
+
     examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset)
     examAidsEither = iso examAidsToEither examAidsFromEither
       where examAidsToEither (ExamAidsPreset p) = Right p

src/Utils/Form.hs

@@ -10,7 +10,7 @@ module Utils.Form where
 
 import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq, urlField)
 import Yesod.Auth (YesodAuth(maybeAuthId))
-  
+
 import Data.Kind (Type, Constraint)
 import qualified Yesod.Form as Yesod
 import Yesod.Core.Instances ()
@@ -94,7 +94,7 @@ _olOptionsGrouped :: Traversal' (OptionList a) (Text, [Option a])
 _olOptionsGrouped f = \case
   x@OptionList{} -> pure x
   x@OptionListGrouped{} -> (\olOptionsGrouped -> x{olOptionsGrouped}) <$> traverse f (olOptionsGrouped x)
-  
+
 _olReadExternal :: Lens' (OptionList a) (Text -> Maybe a)
 _olReadExternal f = \case
   x@OptionList{} -> (\olReadExternal -> x{olReadExternal}) <$> f (olReadExternal x)
@@ -103,7 +103,7 @@ _olReadExternal f = \case
 -- if a field is required, but none should be there
 noField :: Monad m => Field m a
 noField = Field{..}
-  where 
+  where
     fieldParse _ _        = return $ Right Nothing
     fieldView  _ _ _ _ _  = mempty
     fieldEnctype          = UrlEncoded
@@ -576,52 +576,52 @@ runButtonForm' btns fid = do
   return (btnForm, res)
 
 
--- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure 
+-- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure
 --   that the button press still applies to the correct situation
-runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site                    
+runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site
                     , Button site ButtonSubmit, Button site a, Finite a, Hashable h)
   => h -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
 runButtonFormHash (hash -> hVal) fid = do
   currentRoute <- getCurrentRoute
   let bForm = disambiguateButtons $ combinedButtonFieldF ""
-      hForm = aopt hiddenField "" $ Just $ Just hVal      
+      hForm = aopt hiddenField "" $ Just $ Just hVal
-  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> 
+  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
     flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
   let btnForm = wrapForm btnWdgt def  { formAction    = SomeRoute <$> currentRoute
                                       , formEncoding  = btnEnctype
                                       , formSubmit    = FormNoSubmit
                                       }
-  res <- formResultMaybe btnResult $ \case 
+  res <- formResultMaybe btnResult $ \case
     (btn, Just rVal) | hVal == rVal -> return $ Just btn  -- hash value from hidden field must be present and matching
-    _ -> do 
+    _ -> do
-      addMessageI Error MsgBtnFormOutdated 
+      addMessageI Error MsgBtnFormOutdated
       whenIsJust currentRoute redirect                    -- redirect is needed to reset hidden-field value
       return Nothing
   return (btnForm, res)
 
 -- | like runButtonFormHash, but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass.
-runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site                    
+runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site
                       , Button site ButtonSubmit, Button site a, Hashable h)
   => h -> [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
 runButtonFormHash' (hash -> hVal) btns fid = do
   currentRoute <- getCurrentRoute
   let bForm = disambiguateButtons $ combinedButtonField btns ""
-      hForm = aopt hiddenField "" $ Just $ Just hVal      
+      hForm = aopt hiddenField "" $ Just $ Just hVal
-  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html -> 
+  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
     flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
   let btnForm = wrapForm btnWdgt def  { formAction    = SomeRoute <$> currentRoute
                                       , formEncoding  = btnEnctype
                                       , formSubmit    = FormNoSubmit
                                       }
-  res <- formResultMaybe btnResult $ \case 
+  res <- formResultMaybe btnResult $ \case
     (btn, Just rVal) | hVal == rVal -> return $ Just btn  -- hash value from hidden field must be present and matching
-    _ -> do 
+    _ -> do
-      addMessageI Error MsgBtnFormOutdated 
+      addMessageI Error MsgBtnFormOutdated
       whenIsJust currentRoute redirect                    -- redirect is needed to reset hidden-field value
       return Nothing
   return (btnForm, res)
 
-  
+
 -------------------
 -- Custom Fields --
 -------------------
@@ -801,7 +801,7 @@ intMinMaxField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) Fo
 intMinMaxField lower upper = intF{ fieldView=newView }
   where
     intF@Field{ fieldView=oldView } = intField
-    newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq
+    newView theId name attrs = oldView theId name (newAttrs <> attrs)
     newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ]
 
 daysField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime
@@ -873,10 +873,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m
 -- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
 -- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
 --   where splitConditionally :: Text -> [Text]
---         splitConditionally t 
+--         splitConditionally t
 --           | ';' `telem` t = T.split (==';') t
 --           | ',' `telem` t = T.split (==',') t
---           | otherwise  = T.split C.isSeparator t 
+--           | otherwise  = T.split C.isSeparator t
 --         -- Our version of Data.Text does not yet support T.elem
 --         telem :: Char -> Text -> Bool
 --         telem c = T.any (==c)
@@ -885,10 +885,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m
 -- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
 -- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
 --   where splitConditionally :: Text -> [Text]
---         splitConditionally t 
+--         splitConditionally t
 --           | ';' `telem` t = T.split (==';') t
 --           | ',' `telem` t = T.split (==',') t
---           | otherwise  = T.split C.isSeparator t 
+--           | otherwise  = T.split C.isSeparator t
 --         -- Our version of Data.Text does not yet support T.elem
 --         telem :: Char -> Text -> Bool
 --         telem c = T.any (==c)
@@ -978,7 +978,7 @@ multiSelectField' optMsg mkOpts = Field{..}
       let
         rendered = case val of
           Left  _  -> []
-          Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o]            
+          Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o]
         isSel Nothing    = ClassyPrelude.Yesod.null rendered
         isSel (Just opt) = optionExternalValue opt `elem` rendered
       [whamlet|
@@ -1112,7 +1112,7 @@ urlFieldText :: ( Monad m
                 )
              => Field m Text
 urlFieldText = urlField' (pack . ($ mempty) . uriToString id) id
- 
+
 
 -----------
 -- Forms --
@@ -1183,7 +1183,7 @@ type RenderAFormSite site = ( RenderMessage site AFormMessage
                             , RenderMessage site UrlFieldMessage
                             , MonadSecretBox (HandlerFor site)
                             , MonadSecretBox (MaybeT (RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints (Lazy.WriterT [FieldView site] (HandlerFor site))))
-                            , YesodAuth site, HasAppSettings site 
+                            , YesodAuth site, HasAppSettings site
                             )
 
 renderAForm :: (MonadHandler m, RenderAFormSite (HandlerSite m)) => FormLayout -> FormRender m a
@@ -1272,7 +1272,7 @@ doFormHoneypots :: ( MonadHandler m
 doFormHoneypots = and2M
   (getsYesod . views _appBotMitigations $ Set.member SettingBotMitigationUnauthorizedFormHoneypots)
   (is _Nothing <$> maybeAuthId)
-  
+
 honeypotSecrets :: ( MonadSecretBox m
                    , MonadThrow m
                    )
@@ -1285,8 +1285,8 @@ honeypotSecrets = secretBoxCSPRNGPure (encodeUtf8 $ tshow 'honeypotSecrets) (Bin
     secretsNum = 10
 
     randomIdent = decodeUtf8 . Base64.encodeUnpadded . BS.pack <$> replicateM 18 getRandom
-  
+
-  
+
 aformHoneypot :: forall m a.
                  ( RenderAFormSite (HandlerSite m)
                  , MonadHandler m

src/Utils/Icon.hs

@@ -121,6 +121,7 @@ data Icon
   | IconUserEdit
   --  IconMagic           -- indicates automatic updates
   | IconReroute           -- for notification rerouting
+  | IconTop               -- indicating highest number/quantity/priority for something
 
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
   deriving anyclass (Universe, Finite, NFData)
@@ -220,6 +221,7 @@ iconText = \case
     IconUserEdit                -> "user-edit"
     -- IconMagic                   -> "wand-magic"
     IconReroute                 -> "directions"
+    IconTop                     -> "arrow-to-top"
 nullaryPathPiece ''Icon $ camelToPathPiece' 1
 deriveLift ''Icon