chore(firm): add reason for user company association

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

@@ -16,7 +16,7 @@ FirmActNotify: Mitteilung versenden
 FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
 FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
 FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
-FirmActAddSupersvisors: Ansprechpartner hinzufügen
+FirmActAddSupervisors: Ansprechpartner hinzufügen
 FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
 FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{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)}

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

@@ -16,7 +16,7 @@ FirmActNotify: Send message
 FirmActResetSupervision: Reset supervisors for all company associates
 FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
 FirmActResetMutualSupervision: Supervisors supervise each other
-FirmActAddSupersvisors: Add supervisors
+FirmActAddSupervisors: Add supervisors
 FirmActAddSupersEmpty: No supervisors added
 FirmActAddSupersSet n postal: #{n} default company supervisors changed #{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 supervisions terminated") (nact > 0)}

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

@@ -111,4 +111,7 @@ UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für
 UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden!
 UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht.
 UsersRemoveSubordinates usr@Int: Alle Ansprechpartnerbeziehungen für #{tshow usr} #{pluralDE usr "ehemaligen" "ehemalige"} Ansprechpartner gelöscht.
-SupervisorReason: Begründung
+UserCompanyReason: Begründung der Firmenassoziation
+UserCompanyReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.
+UserSupervisorReason: Begründung Ansprechpartner
+UserSupervisorReasonTooltip: Optionale Notiz für besondere Fälle. Kann ggf. autmatische Entfernung bei AVS Firmenwechsel verhindern.

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

@@ -111,4 +111,7 @@ UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{plur
 UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
 UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
 UsersRemoveSubordinates usr: Removed all subordinates for #{pluralENsN usr "previous supervisor"}.
-SupervisorReason: Reason
+UserCompanyReason: Reason for company association
+UserCompanyReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.
+UserSupervisorReason: Reason for supervision
+UserSupervisorReasonTooltip: Optional note for special cases. In some case this may prevent automatic removel upon AVS user company changes.

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -84,6 +84,7 @@ TableCompanyNos: Firmennummern
 TableCompanyUser: Firmenangehöriger
 TableCompanyNrUsers: Firmenangehörige
 TableCompanyNrSecondaryUsers: Sekundäre Firmenangehörige
+TableCompanyReason: Notiz
 TableCompanyNrSupers: Ansprechpartner
 TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner
 TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung
@@ -97,6 +98,7 @@ TableRerouteActive: Umleitung
 TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
 TableSupervisor: Ansprechpartner
 TableSupervisee: Ansprechpartner für
+TableReason: Begründung
 TableCreationTime: Erstellungszeit
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameter

messages/uniworx/utils/table_column/en-eu.msg

@@ -84,6 +84,7 @@ TableCompanyNos: Company numbers
 TableCompanyUser: Associate
 TableCompanyNrUsers: Associates
 TableCompanyNrSecondaryUsers: Secondary Associates
+TableCompanyReason: Note
 TableCompanyNrSupers: Supervisors
 TableCompanyNrEmpSupervised: Supervised employees 
 TableCompanyNrEmpRerouted: Employees having reroute
@@ -97,6 +98,7 @@ TableRerouteActive: Reroute
 TableCompanyPostalPreference: Default notification preference
 TableSupervisor: Supervisor
 TableSupervisee: Supervisor for
+TableReason: Reason
 TableCreationTime: Creation
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameters

models/users.model

@@ -93,6 +93,7 @@ UserCompany
     supervisorReroute     Bool       default=false -- if supervisor is true, should this supervisor receive email for _new_ company users?
     priority              Int        default=0     -- higher number, higher priority; default=1 for Haskell-Code
     useCompanyAddress     Bool       default=true  -- if true, CompanyPostalAddress and CompanyEmail are used if UserPostalAddress/UserDisplayEmail are Nothing, respects priority
+    reason                Text Maybe -- miscellaneous note, e.g. Superior
     UniqueUserCompany user company   -- a user may belong to multiple companies, but to each one only once
     deriving Generic Show
 UserSupervisor

src/Handler/Firm.hs

@@ -56,7 +56,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU
 
 data FirmAction = FirmActNotify
                 | FirmActResetSupervision
-                | FirmActAddSupersvisors
+                | FirmActAddSupervisors
                 | FirmActChangeContactFirm
                 | FirmActChangeContactUser
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@@ -70,10 +70,11 @@ data FirmActionData = FirmActNotifyData
                         { firmActResetKeepOldSupers       :: Maybe Bool
                         , firmActResetMutualSupervision   :: Maybe Bool
                         }
-                    | FirmActAddSupersvisorsData
+                    | FirmActAddSupervisorsData
                         { firmActAddSupervisorIds         :: Set Text
                         , firmActAddSupervisorReroute     :: Bool
                         , firmActAddSupervisorPostal      :: Maybe Bool
+                        , firmActAddSupervisorReason      :: Maybe Text
                         }
                     | FirmActChangeContactFirmData
                         { firmActCCFPostalAddr            :: Maybe StoredMarkup
@@ -93,10 +94,12 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
     mkAct _     FirmActResetSupervision = singletonMap FirmActResetSupervision $      FirmActResetSupervisionData
                   <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                     (Just $ Just False)
                   <*> aopt checkBoxField                                      (fslI MsgFirmActResetMutualSupervision)             (Just $ Just True )
-    mkAct _     FirmActAddSupersvisors   = singletonMap FirmActAddSupersvisors   $ FirmActAddSupersvisorsData
+    mkAct _     FirmActAddSupervisors   = singletonMap FirmActAddSupervisors   $ FirmActAddSupervisorsData
                   <$> areq (textField & cfAnySeparatedSet)  (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip)  Nothing
                   <*> areq checkBoxField                    (fslI MsgTableIsDefaultReroute)                                                             (Just True)
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip)                                Nothing
+                  <*> aopt (textField & cfStrip & addDatalist ucdefSuperReasons)
+                                                            (fslI MsgUserCompanyReason & setTooltip MsgUserCompanyReasonTooltip)                        Nothing
     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
@@ -106,6 +109,13 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
                   <$> aopt htmlField                        (fslI MsgPostAddress      & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
                   <*> aopt postalEmailField                 (fslI MsgFormFieldPostal  & setTooltip MsgFormFieldPostalTip) Nothing
     mkAct _  _ = mempty
+    ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text)
+    ucdefSuperReasons = 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
+        return $ usrc E.^. UserCompanyReason
+
 
 firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData
 firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing
@@ -142,11 +152,11 @@ firmActionHandler route isAdmin = flip formResult faHandler
                         E.&&.  usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
                   )
           else return 0
-        newSupers <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids
+        newSupers <- addDefaultSupervisorsFor Nothing madId (firmActResetMutualSupervision /= Just False) fids
         addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams route -- reload to reflect changes
 
-    faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do
+    faHandler (FirmActAddSupervisorsData{..}, 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
           usersFound = mapMaybe snd usersFound'
@@ -164,7 +174,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
       runDB $ do
         -- putMany [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] -- putMany always overwrites existing records, which would destroy priority and useCompanyAddress here
         -- upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [copyField UserCompanySupervisor, copyField UserCompanySupervisorReroute] [] [] -- overwrite Supervisor and SupervisorReroute, keep priority and useCompanyAddress
-        upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False | uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute] [] -- identical to previous line, but perhaps more clear?
+        upsertManyWhere [UserCompany uid cid True firmActAddSupervisorReroute 0 False firmActAddSupervisorReason| uid <- usersFound] [] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmActAddSupervisorReroute, UserCompanyReason =. firmActAddSupervisorReason] [] -- identical to previous line, but perhaps more clear?
         whenIsJust firmActAddSupervisorPostal $ \prefPostal ->
           updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal]
         addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal
@@ -242,12 +252,13 @@ deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList
 resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
 resetSupervisors cid employees = do
   nr_del <- deleteSupervisors employees [cid]
-  nr_add <- addDefaultSupervisors cid employees
+  let superReasonComDef = Just $ tshow SupervisorReasonCompanyDefault
+  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 :: CompanyId -> NonEmpty UserId -> DB Int64
+addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
-addDefaultSupervisors cid employees = do
+addDefaultSupervisors reason cid employees = do
   E.insertSelectWithConflictCount UniqueUserSupervisor
     (do
       (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
@@ -258,17 +269,17 @@ addDefaultSupervisors cid employees = do
         E.<&>  usr
         E.<&> (spr E.^. UserCompanySupervisorReroute)
         E.<&> E.justVal cid
-        E.<&> E.nothing
+        E.<&> E.val reason
     )
-    (\_old new ->
+    (\old new ->
       [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
       , UserSupervisorCompany E.=. E.justVal cid
-      -- , UserSupervisorReason  E.=. new E.^. UserSupervisorReason -- keep any existing reason
+      , 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 UserId -> Bool -> mono -> DB Int64
+addDefaultSupervisorsFor ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
-addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
+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)
@@ -288,17 +299,17 @@ addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
         E.<&> (usr E.^. UserCompanyUser)
         E.<&> (spr E.^. UserCompanySupervisorReroute)
         E.<&> E.just (spr E.^. UserCompanyCompany)
-        E.<&> E.nothing
+        E.<&> E.val reason
     )
-    (\_old new ->
+    (\old new ->
         [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
         , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-        -- , UserSupervisorReason  E.=. new E.^. UserSupervisorReason   -- keep any existing reaon
+        , 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) => Bool -> mono -> DB Int64
+addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
-addDefaultSupervisorsAll mutualSupervision cids = do
+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)
@@ -313,12 +324,12 @@ addDefaultSupervisorsAll mutualSupervision cids = do
         E.<&> (usr E.^. UserCompanyUser)
         E.<&> (spr E.^. UserCompanySupervisorReroute)
         E.<&> E.just (spr E.^. UserCompanyCompany)
-        E.<&> E.nothing
+        E.<&> E.val reason
     )
-    (\_old new ->
+    (\old new ->
         [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
         , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
-        -- , UserSupervisorReason  E.=. new E.^. UserSupervisorReason   -- keep any existing reaon
+        , UserSupervisorReason  E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
         ] )
 
 
@@ -812,6 +823,7 @@ data FirmUserActionData = FirmUserActNotifyData
                         | FirmUserActSetSupervisorData
                             {  firmUserActSetSuperNames   :: Maybe (Set Text)
                             ,  firmUserActSetSuperIds     :: Maybe [UserId]
+                            ,  firmUserActSetSuperReason  :: Maybe Text
                             ,  firmUserActSetSuperReroute :: Bool
                             ,  firmUserActSetSuperKeep    :: Bool
                             }
@@ -905,6 +917,7 @@ mkFirmUserTable isAdmin cid = do
           , sortable (Just "reroutes")        (i18nCell MsgTableCompanyNrRerouteActive)  $ \(view resultUserCompanyReroutes     -> nr) -> wgtCell $ word2widget nr
           , sortable (Just "postal-pref")     (i18nCell MsgPrefersPostal)                $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
           , colUserEmail
+          , sortable (Just "usr-reason")      (i18nCell MsgTableCompanyReason)           $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r
           , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
           ]
         dbtSorting = mconcat
@@ -915,6 +928,7 @@ mkFirmUserTable isAdmin cid = do
           , singletonMap "personal-number"  $ SortColumn $ queryUserUser        >>> (E.^. UserCompanyPersonalNumber)
           , singletonMap "supervisors"      $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
           , singletonMap "reroutes"         $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
+          , singletonMap "usr-reason"       $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)
           ]
         dbtFilter = mconcat
           [ single $ fltrUserNameEmail queryUserUser
@@ -991,6 +1005,13 @@ mkFirmUserTable isAdmin cid = do
           , prismAForm (singletonFilter "is-primary-company"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI   MsgFilterFirmPrimary)
           ]
         dbtStyle =  def { dbsFilterLayout = defaultDBSFilterLayout }
+        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
+            usrc <- E.from $ E.table @UserSupervisor
+            E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
+                  E.&&. usrc E.^. UserSupervisorCompany E.~=. E.val cid
+            return $ usrc E.^. UserSupervisorReason
         acts :: Map FirmUserAction (AForm Handler FirmUserActionData)
         acts = mconcat
           [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
@@ -1000,6 +1021,7 @@ mkFirmUserTable isAdmin cid = do
           , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
               <$> aopt (textField & cfAnySeparatedSet)                    (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
               <*> aopt supervisorsField                                   (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip)                          Nothing
+              <*> aopt (textField & cfStrip & addDatalist superReasons)   (fslI MsgUserSupervisorReason  & setTooltip MsgUserSupervisorReasonTooltip)          Nothing
               <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
               <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep)                                                     (Just False)
           , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
@@ -1083,7 +1105,7 @@ postFirmUsersR fsh = do
         delSupers <- if firmUserActResetKeepOldSupers == Just False
           then deleteSupervisors uids []
           else return 0
-        newSupers <- addDefaultSupervisors cid uids
+        newSupers <- addDefaultSupervisors Nothing cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
     (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do
@@ -1103,7 +1125,7 @@ postFirmUsersR fsh = do
         in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
       delSupers <- runDB
          $ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep
-        <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) Nothing | u <- toList uids, s <- newSupers]
+        <* 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
 
@@ -1121,7 +1143,7 @@ postFirmUsersR fsh = do
         addMessageI Success $ MsgFirmUserChanges nrChanged
         reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 
-  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser]
+  formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
 
   siteLayout (citext2widget companyName) $ do
     setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
@@ -1351,7 +1373,7 @@ postFirmSupersR fsh = do
       cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser]
       redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
 
-  formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm]
+  formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupervisors, FirmActResetSupervision, FirmActChangeContactFirm]
 
   siteLayout (citext2widget fsh) $ do
     setTitle $ citext2Html $ fsh <> " Supers"

src/Handler/Profile.hs

@@ -1092,8 +1092,8 @@ mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
                 if isReroute
                   then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter)
                   else mempty
-        , sortable (Just "cshort")      (i18nCell MsgTableCompany)        $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
+        , sortable (Just "cshort")      (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
-        , sortable (Just "reason")      (i18nCell MsgSupervisorReason)    $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
+        , sortable (Just "reason")      (i18nCell MsgTableReason)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
         ]
     validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
     dbtSorting = mconcat
@@ -1142,8 +1142,8 @@ mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
         , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
             let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
             in  tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
-        , sortable (Just "cshort")      (i18nCell MsgTableCompany)        $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
+        , sortable (Just "cshort")      (i18nCell MsgTableCompany)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
-        , sortable (Just "reason")      (i18nCell MsgSupervisorReason)    $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
+        , sortable (Just "reason")      (i18nCell MsgTableReason)   $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason  -> mr) -> maybeCell mr textCell
         ]
     validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
     dbtSorting = mconcat

src/Handler/Tutorial/Form.hs

@@ -91,7 +91,7 @@ tutorialForm cid template html = do
   where
     tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text))
     tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (toPathPiece $ CI.original t)) . Set.toAscList) . runDB $
-      fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
+      fmap (setOf $ folded . _Value) . E.select . E.distinct . E.from $ \tutorial -> do
         E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
         return $ tutorial E.^. TutorialType
 

src/Handler/Users.hs

@@ -186,6 +186,12 @@ postUsersR = do
         let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
         return (act, usrSet)
 
+      superReasons :: HandlerFor UniWorX (OptionList Text)
+      superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
+        fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do
+          usrc <- Ex.from $ Ex.table @UserSupervisor
+          E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
+          return $ usrc E.^. UserSupervisorReason
       acts :: Map UserAction (AForm Handler UserActionData)
       acts = mconcat
         [ singletonMap UserLdapSync      $ pure UserLdapSyncData
@@ -193,11 +199,11 @@ postUsersR = do
         , singletonMap UserAddSupervisor $ UserAddSupervisorData
             <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
             <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
-            <*> aopt   textField (fslI MsgSupervisorReason) Nothing
+            <*> aopt  (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
         , singletonMap UserSetSupervisor $ UserSetSupervisorData
             <$> apopt  (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
             <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
-            <*> aopt   textField (fslI MsgSupervisorReason) Nothing
+            <*> aopt  (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
         , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
         , singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData
         ]

src/Handler/Utils/Avs.hs

@@ -394,7 +394,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
             --           | otherwise
             --             -> Nothing
             superReasonComDef = tshow SupervisorReasonCompanyDefault
-            newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
+            newUserComp = UserCompany usrId newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
 
         usr_up2 <- case oldAvsFirmInfo of
           _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
@@ -550,7 +550,7 @@ createAvsUserById muid api = do
                   }
             runDB $ do        -- any failure must rollback all DB write transactions here
               uid <- maybeThrowM (AvsUserCreationFailed api) $ addNewUserDB newUserData
-              let userComp = UserCompany uid cid False False 1 True -- default value for new company insertion, if no update can be done
+              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
@@ -682,8 +682,8 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
           return . E.max_ $ usrCmp E.^. UserCompanyPriority
         let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
         suprEnt <- upsertBy (UniqueUserCompany supid cid)
-                              (UserCompany supid cid True False maxPrio True)
+                              (UserCompany supid cid True False maxPrio True reasonSuperior)
-                              [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio]
+                              [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio, UserCompanyReason =. reasonSuperior]
         E.insertSelectWithConflict UniqueUserSupervisor
           (do
             usr <- E.from $ E.table @UserCompany

src/Handler/Utils/Company.hs

@@ -110,11 +110,12 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
         void $ insertUnique newUserComp
         addCompanySupervisors newCompanyId uid
         return (usrUpdate, mempty)
-      Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute}
+      Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
         | newCompanyId == oldCompanyId -> return mempty -- nothing to do
         | otherwise -> do -- switch company
+            when (isNothing oldAssocReason) $ deleteBy $ UniqueUserCompany uid oldCompanyId
             void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
-              [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True]
+              [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True, UserCompanyReason =. Nothing]
             -- supervised by uid
             supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
               usrSup <- E.from $ E.table @UserSupervisor
@@ -147,5 +148,5 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
                            newlyUnsupervised
             return (usrUpdate ,problems)
   where
-    newUserComp       = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
+    newUserComp       = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
     superReasonComDef = tshow SupervisorReasonCompanyDefault

src/Handler/Utils/Users.hs

@@ -1000,11 +1000,13 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         E.<&> (userCompany E.^. UserCompanySupervisorReroute)
         E.<&> (userCompany E.^. UserCompanyPriority)
         E.<&> (userCompany E.^. UserCompanyUseCompanyAddress)
+        E.<&> (userCompany E.^. UserCompanyReason)
     )
     (\current excluded ->
       [ UserCompanySupervisor         E.=. E.greatest (current E.^. UserCompanySupervisor)        (excluded E.^. UserCompanySupervisor)       -- t > f
       , UserCompanyPriority           E.=. E.greatest (current E.^. UserCompanyPriority)          (excluded E.^. UserCompanyPriority)
       , UserCompanyUseCompanyAddress  E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress)
+      , UserCompanyReason             E.=. E.coalesce [current E.^. UserCompanyReason             ,excluded E.^. UserCompanyReason]
       ]
     )
   deleteWhere [ UserCompanyUser ==. oldUserId]

src/Model/Types/Misc.hs

@@ -65,6 +65,8 @@ data SupervisorReason
   deriving (Eq, Ord, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite, NFData)
 
+-- NOTE: it is intentional not to have an embedRenderMessage here; within the DB, we allow arbitrary text, but we do match on these ones to recognise certain functions
+--       so do not change values here without a proper migration
 instance Show SupervisorReason where
   show SupervisorReasonCompanyDefault = "Firmenstandard"
   show SupervisorReasonAvsSuperior    = "Vorgesetzer"

test/Database/Fill.hs

@@ -655,25 +655,25 @@ fillDb = do
                           , let rcName  = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n)
                           , let rcShort = CI.mk $ "RC" <> tshow n
                           ]
-  void . insert' $ UserCompany jost    fraportAg    True   True  0 False
+  void . insert' $ UserCompany jost    fraportAg    True   True  0 False $ Just "Vorgesetzter"
-  void . insert' $ UserCompany svaupel nice         True   False 2 False
+  void . insert' $ UserCompany svaupel nice         True   False 2 False $ Just "Vorgesetzter"
-  void . insert' $ UserCompany svaupel ffacil       False  False 1 False
+  void . insert' $ UserCompany svaupel ffacil       False  False 1 False $ Just "Irgendwas"
-  void . insert' $ UserCompany svaupel bpol         True   False 2 False
+  void . insert' $ UserCompany svaupel bpol         True   False 2 False $ Just "Irgendwas"
-  void . insert' $ UserCompany svaupel fraGround    True   False 1 False
+  void . insert' $ UserCompany svaupel fraGround    True   False 1 False $ Just "Irgendwas"
-  void . insert' $ UserCompany gkleen  nice         False  False 1 True
+  void . insert' $ UserCompany gkleen  nice         False  False 1 True  $ Just "Winterdienst"
-  void . insert' $ UserCompany gkleen  fraGround    False  True  2 False
+  void . insert' $ UserCompany gkleen  fraGround    False  True  2 False $ Just "Irgendwas"
-  void . insert' $ UserCompany gkleen  bpol         False  True  1 False
+  void . insert' $ UserCompany gkleen  bpol         False  True  1 False $ Just "Irgendwas"
-  void . insert' $ UserCompany fhamann bpol         False  False 1 True
+  void . insert' $ UserCompany fhamann bpol         False  False 1 True  $ Just "Irgendwas"
-  void . insert' $ UserCompany fhamann ffacil       True   True  2 True
+  void . insert' $ UserCompany fhamann ffacil       True   True  2 True  $ Just "Irgendwas"
-  void . insert' $ UserCompany fhamann nice         False  False 3 False
+  void . insert' $ UserCompany fhamann nice         False  False 3 False $ Just "Winterdienst"
-  void . insert' $ UserCompany sbarth  nice         False  False 3 False
+  void . insert' $ UserCompany sbarth  nice         False  False 3 False $ Just "Winterdienst"
-  void . insert' $ UserCompany sbarth  bpol         True   True  1 True
+  void . insert' $ UserCompany sbarth  bpol         True   True  1 True  $ Just "Irgendwas"
   -- need more tests
-  insertMany_ [UserCompany uid fraGround False False 0 True | Entity uid User{userFirstName = "John"} <- matUsers]
+  insertMany_ [UserCompany uid fraGround False False 0 True Nothing | Entity uid User{userFirstName = "John"} <- matUsers]
-  insertMany_ [UserCompany uid bpol False False 0 False     | Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
+  insertMany_ [UserCompany uid bpol False False 0 False     Nothing | Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
-  insertMany_ [UserCompany uid bpol True True 0 True        | Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
+  insertMany_ [UserCompany uid bpol True True 0 True        Nothing | Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
-  insertMany_ [UserCompany uid ffacil False False 0 False   | Entity uid User{userSurname = "Walker"} <- matUsers]
+  insertMany_ [UserCompany uid ffacil False False 0 False   Nothing | Entity uid User{userSurname = "Walker"} <- matUsers]
-  insertMany_ [UserCompany uid rckey issuper False 0 True
+  insertMany_ [UserCompany uid rckey issuper False 0 True Nothing
               | rckey <- randComps
               , Just n <- [readMay $ drop 2 $ unpack $ CI.original $ unCompanyKey rckey]
               , Entity uid User{userSurname = uSurname} <- take (n `div` 20) $ drop (2*n) matUsers
@@ -699,9 +699,9 @@ fillDb = do
               , UserSupervisor gkleen gkleen          True  (Just fraGround)  (Just "Staff")
               , UserSupervisor tinaTester tinaTester  False Nothing           (Just "Staff")
               ]
-              ++ take 444 [ UserSupervisor fhamann uid True  Nothing (Just $ tshow SupervisorReasonCompanyDefault) | Entity uid _ <-          matUsers, uid /= jost]
+              ++ take 444 [ UserSupervisor fhamann uid True  Nothing (Just $ tshow SupervisorReasonCompanyDefault)        | Entity uid _ <-          matUsers, uid /= jost]
-              ++ take 123 [ UserSupervisor gkleen  uid True  Nothing Nothing                                       | Entity uid _ <- drop 369 matUsers ]
+              ++ take 123 [ UserSupervisor gkleen  uid True  Nothing Nothing                                              | Entity uid _ <- drop 369 matUsers ]
-              ++ take  11 [ UserSupervisor jost    uid False Nothing (Just $ tshow SupervisorReasonAvsSuperior)    | Entity uid _ <- drop 501 matUsers ]
+              ++ take  11 [ UserSupervisor jost    uid False (Just fraportAg) (Just $ tshow SupervisorReasonAvsSuperior)  | Entity uid _ <- drop 501 matUsers ]
   upsertManyWhere supvs [] [] []
   -- insertMany_ supvs              -- NOTE: multiple calls like this throw a runtime error!
   -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok