refactor(company): supervison and company tables changed

- company avs id must be unique now, companies with id 0 are deleted
- user supervision can be annotated with company and or a reason, used to avoid accidental supervision relations; company supervision resets ignore non-company supervisions

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

@@ -102,3 +102,4 @@ Name !ident-ok: Name
 UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt.
 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.
+SupervisorReason: Begründung

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

@@ -101,4 +101,5 @@ AuthKindNoLogin: No login
 Name: Name
 UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set.
 UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
-UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
+UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
+SupervisorReason: Reason

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

@@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner
 TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
 TableCompanyNrRerouteDefault: Standard Umleitungen
 TableCompanyNrRerouteActive: Aktive Umleitungen
+TableRerouteActive: Umleitung
 TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige
 TableSupervisor: Ansprechpartner
+TableSupervisee: Ansprechpartner für
 TableCreationTime: Erstellungszeit
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameter

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

@@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Default supervisors
 TableCompanyNrForeignSupers: External Supervisors
 TableCompanyNrRerouteDefault: Default reroutes
 TableCompanyNrRerouteActive: Active reroutes
+TableRerouteActive: Reroute
 TableCompanyPostalPreference: Default notification preference
 TableSupervisor: Supervisor
+TableSupervisee: Supervisor for
 TableCreationTime: Creation
 TableJob !ident-ok: Job
 TableJobContent !ident-ok: Parameters

models/company.model

@@ -6,15 +6,15 @@
 
 Company  
   name            CompanyName             -- == (CI Text)
-  shorthand       CompanyShorthand        -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId    FUTURE TODO: a shorthand will become available through the AVS interface in the future
+  shorthand       CompanyShorthand        -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId   A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness
   avsId           Int     default=0       -- primary key from avs
   prefersPostal   Bool    default=false   -- new company users prefers letters by post instead of email
   postAddress     StoredMarkup Maybe      -- default company postal address, including company name 
   email           UserEmail Maybe         -- Case-insensitive generic company eMail address
   UniqueCompanyName name 
-  UniqueCompanyShorthand shorthand
+  -- UniqueCompanyShorthand shorthand     -- unnecessary, since it is the primary key already
-  -- UniqueCompanyAvsId avsId             -- should be the case, unclear if enforcing works here, since we cannot query avs by company id
+  UniqueCompanyAvsId avsId  
-  Primary shorthand             -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
+  Primary shorthand                       -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand }
   deriving Ord Eq Show Generic Binary
 
 -- TODO: a way to populate this table (manually)

models/users.model

@@ -94,9 +94,11 @@ UserCompany
     UniqueUserCompany user company   -- a user may belong to multiple companies, but to each one only once
     deriving Generic
 UserSupervisor
-    supervisor            UserId -- multiple supervisor per trainee possible
+    supervisor            UserId          -- multiple supervisor per trainee possible
     user                  UserId
-    rerouteNotifications  Bool   -- User can be his own supervisor to receive notifications as well
+    rerouteNotifications  Bool            -- User can be his own supervisor to receive notifications as well
-    UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
+    company               CompanyId Maybe -- this supervisor was company default supervisor at time of entry
+    reason                Text      Maybe -- miscellanoues reason, e.g. Winterservice supervisision
+    UniqueUserSupervisor supervisor user  -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
     deriving Generic
     

src/Handler/Firm.hs

@@ -174,7 +174,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
             , (CompanyPrefersPostal =.)        <$>           firmActCCFPostalPref
             ]
       in unless (null changes) $ do
-        runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes
+        runDB $ update cid changes
         addMessageI Success MsgFirmActChangeContactFirmResult
         reloadKeepGetParams route
 
@@ -229,14 +229,16 @@ runFirmActionFormPost cid route isAdmin acts = do
 
 
 
--- remove supervisors:
+-- | remove supervisors for given users; maybe restricted to those linked to a given companies
-deleteSupervisors :: NonEmpty UserId -> DB Int64
+deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64
-deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs]
+deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList usrs) : restrictByCompany
+  where
+    restrictByCompany = guardMonoid (notNull cids) [UserSupervisorCompany <-. (Just <$> cids)]      
 
--- reset supervisors given employees of a company to default company supervision, deleting all other supervisors
+-- reset supervisors given employees of a company to default company supervision, deleting all previous company-related supervisors
 resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64
 resetSupervisors cid employees = do
-  nr_del <- deleteSupervisors employees
+  nr_del <- deleteSupervisors employees [cid]
   nr_add <- addDefaultSupervisors cid employees
   return $ max nr_del nr_add
 
@@ -252,8 +254,14 @@ addDefaultSupervisors cid employees = do
         E.<#  (spr E.^. UserCompanyUser)
         E.<&>  usr
         E.<&> (spr E.^. UserCompanySupervisorReroute)
+        E.<&> E.justVal cid
+        E.<&> E.nothing
     )
-    (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications])
+    (\_old new -> 
+      [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
+      , UserSupervisorCompany E.=. E.justVal cid      
+      -- , UserSupervisorReason  E.=. 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
@@ -276,8 +284,14 @@ addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
         E.<#  (spr E.^. UserCompanyUser)
         E.<&> (usr E.^. UserCompanyUser)
         E.<&> (spr E.^. UserCompanySupervisorReroute)
+        E.<&> E.just (spr E.^. UserCompanyCompany)
+        E.<&> E.nothing
     )
-    (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
+    (\_old new -> 
+        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
+        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
+        -- , UserSupervisorReason  E.=. new E.^. UserSupervisorReason   -- keep any existing reaon
+        ] )
 
 -- like `addDefaultSupervisors`, but selects all employees of given companies from database
 addDefaultSupervisorsAll ::  (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64
@@ -295,8 +309,14 @@ addDefaultSupervisorsAll mutualSupervision cids = do
         E.<#  (spr E.^. UserCompanyUser)
         E.<&> (usr E.^. UserCompanyUser)
         E.<&> (spr E.^. UserCompanySupervisorReroute)
+        E.<&> E.just (spr E.^. UserCompanyCompany)
+        E.<&> E.nothing
     )
-    (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] )
+    (\_old new -> 
+        [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
+        , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
+        -- , UserSupervisorReason  E.=. new E.^. UserSupervisorReason   -- keep any existing reaon
+        ] )
 
 
 ------------------------------
@@ -1006,7 +1026,7 @@ postFirmUsersR fsh = do
     (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do  -- set guaranteed to be non-empty due to first case clause
       runDB $ do
         delSupers <- if firmUserActResetKeepOldSupers == Just False
-          then deleteSupervisors uids
+          then deleteSupervisors uids []
           else return 0
         newSupers <- addDefaultSupervisors cid uids
         addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
@@ -1027,8 +1047,8 @@ postFirmUsersR fsh = do
               |]
         in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
       delSupers <- runDB
-         $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep
+         $ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep
-        <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers]
+        <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) Nothing | u <- toList uids, s <- newSupers]
       addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
       reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
 

src/Handler/LMS/Fake.hs

@@ -71,11 +71,11 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
     theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1]
     let addSupervisor = case theSupervisor of 
           [s] -> \suid k -> case k of 
-                    1 -> void $ insertBy $ UserSupervisor s suid True
+                    1 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
                     2 -> do
-                          void $ insertBy $ UserSupervisor s    suid True
+                          void $ insertBy $ UserSupervisor s    suid True Nothing (Just "Test")
-                          void $ insertBy $ UserSupervisor suid suid True
+                          void $ insertBy $ UserSupervisor suid suid True Nothing Nothing
-                    3 -> void $ insertBy $ UserSupervisor s suid True
+                    3 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing
                     _ -> return ()
           _   -> \_ _ -> return ()
         expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)]

src/Handler/Profile.hs

@@ -2,6 +2,8 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity and HasUser instances
+
 module Handler.Profile
   ( getProfileR, postProfileR
   , getForProfileR, postForProfileR
@@ -622,12 +624,14 @@ makeProfileData (Entity uid User{..}) = do
         (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
       -- icnReroute = text2widget " " <> toWgt (icon IconLetter)
   --Tables
-  (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
+  (hasRowsOwnedCourses, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
   enrolledCoursesTable <- mkEnrolledCoursesTable      uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
   submissionTable      <- mkSubmissionTable           uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
   submissionGroupTable <- mkSubmissionGroupTable      uid -- Tabelle mit allen Abgabegruppen
   correctionsTable     <- mkCorrectionsTable          uid -- Tabelle mit allen Korrektor-Aufgaben
   qualificationsTable  <- mkQualificationsTable  now  uid -- Tabelle mit allen Qualifikationen
+  supervisorsTable     <- mkSupervisorsTable          uid -- Tabelle mit allen Supervisors
+  superviseesTable     <- mkSuperviseesTable          uid -- Tabelle mit allen Supervisees
   let examTable, ownTutorialTable, tutorialTable :: Widget
       examTable        = i18n MsgPersonalInfoExamAchievementsWip
       ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
@@ -1006,6 +1010,106 @@ mkQualificationsTable =
       }
 
 
+-- Types & Definitions used for both mkSupervisorsTable and mkSuperviseeTable
+type TblSupervisorExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserSupervisor)  -- `E.LeftOuterJoin` E.SqlExpr (Entity Company)
+type TblSupervisorData = DBRow (Entity User, Entity UserSupervisor)
+
+queryUser            :: TblSupervisorExpr -> E.SqlExpr (Entity User)
+queryUser            = $(E.sqlIJproj 2 1)
+queryUserSupervisor  :: TblSupervisorExpr -> E.SqlExpr (Entity UserSupervisor)
+queryUserSupervisor  = $(E.sqlIJproj 2 2)
+resultUser           :: Lens' TblSupervisorData (Entity User)
+resultUser           = _dbrOutput . _1
+resultUserSupervisor :: Lens' TblSupervisorData (Entity UserSupervisor)
+resultUserSupervisor = _dbrOutput . _2
+
+instance HasEntity TblSupervisorData User where
+  hasEntity = _dbrOutput . _1
+instance HasUser TblSupervisorData where
+  hasUser = _dbrOutput . _1 . _entityVal
+
+-- | Table listing all supervisor of the given user
+mkSupervisorsTable :: UserId -> DB Widget
+mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
+  where 
+    dbtIdent = "userSupervisedBy" :: Text
+    dbtStyle = def
+
+    dbtSQLQuery (usr `E.InnerJoin` spr) = do
+        E.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
+        E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid
+        return (usr, spr)
+    dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
+    dbtProj = dbtProjId
+
+    dbtColonnade = mconcat
+        [ colUserNameModalHdr MsgTableSupervisor ForProfileDataR
+        , colUserEmail
+        , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b          
+        , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
+        , 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          
+        ]
+    validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
+    dbtSorting = mconcat
+        [ singletonMap & uncurry $ sortUserNameLink queryUser
+        , singletonMap & uncurry $ sortUserEmail    queryUser
+        , singletonMap "postal-pref"  $ SortColumn $ queryUser            >>> (E.^. UserPrefersPostal)
+        , singletonMap "rerouted"     $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorRerouteNotifications)
+        , singletonMap "cshort"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorCompany)
+        , singletonMap "reason"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorReason)          
+        ]
+    dbtFilter  = mconcat
+        [ singletonMap & uncurry $ fltrUserNameEmail queryUser
+        ]
+    dbtFilterUI = mempty
+    dbtParams = def
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+    dbtExtraReps = []
+
+
+-- | Table listing all persons supervised by the given user
+mkSuperviseesTable :: UserId -> DB Widget
+mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
+  where 
+    dbtIdent = "userSupervisedBy" :: Text
+    dbtStyle = def
+
+    dbtSQLQuery (usr `E.InnerJoin` spr) = do
+        E.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId
+        E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid
+        return (usr, spr)
+    dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
+    dbtProj = dbtProjId
+
+    dbtColonnade = mconcat
+        [ colUserNameModalHdr MsgTableSupervisee ForProfileDataR
+        -- , colUserEmail
+        -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal)       $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b          
+        , sortable (Just "rerouted")    (i18nCell MsgTableRerouteActive)  $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
+        , 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          
+        ]
+    validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
+    dbtSorting = mconcat
+        [ singletonMap & uncurry $ sortUserNameLink queryUser
+        , singletonMap & uncurry $ sortUserEmail    queryUser
+        , singletonMap "postal-pref"  $ SortColumn $ queryUser            >>> (E.^. UserPrefersPostal)
+        , singletonMap "rerouted"     $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorRerouteNotifications)
+        , singletonMap "cshort"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorCompany)
+        , singletonMap "reason"       $ SortColumn $ queryUserSupervisor  >>> (E.^. UserSupervisorReason)          
+        ]
+    dbtFilter  = mconcat
+        [ singletonMap & uncurry $ fltrUserNameEmail queryUser
+        ]
+    dbtFilterUI = mempty
+    dbtParams = def
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+    dbtExtraReps = []
+
+
 getAuthPredsR, postAuthPredsR :: Handler Html
 getAuthPredsR = postAuthPredsR
 postAuthPredsR = do

src/Handler/Users.hs

@@ -64,8 +64,8 @@ embedRenderMessage ''UniWorX ''UserAction id
 
 data UserActionData = UserLdapSyncData 
                     | UserHijack
-                    | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } 
+                    | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } 
-                    | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool }
+                    | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
                     | UserRemoveSupervisorData
                     | UserAvsSyncData
   deriving (Eq, Ord, Read, Show, Generic)
@@ -192,9 +192,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
         , 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
         , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
         ]
 
@@ -385,7 +387,7 @@ postUsersR = do
             nrSuperNotFound = length supersNotFound            
         runDB $ do
           unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users]
-          putMany [UserSupervisor s u r 
+          putMany [UserSupervisor s u r Nothing (getActionSupervisorReason act)
                   | let r = getActionRerouteNotifications act
                   , (_, Just s) <- supersFound
                   , u <- users

src/Handler/Utils/Avs.hs

@@ -628,8 +628,9 @@ updateAvsUserByIds apids = do
               usr_ups = mcons eml_up $ frm_ups <> per_ups
               -- TODO: update Company
               -- cmp_up = let
-              --               cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo)
+              --            cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo)
-              --               cno_new = (oldAvsFirmInfo ^.         _avsFirmFirmNo)
+              --            cno_new = (oldAvsFirmInfo ^.         _avsFirmFirmNo)
+              --           in 
               --               cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm  )
               --               cmp_new = (oldAvsFirmInfo ^.         _avsFirmFirm  )
 

src/Handler/Utils/Company.hs

@@ -15,14 +15,14 @@ import qualified Data.Text as Text
 import Database.Persist.Postgresql
 
 -- | Ensure that the given user is linked to the given company
-upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB ()
+upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking
 upsertUserCompany uid (Just cName) cAddr | notNull cName = do 
   cid <- upsertCompany cName cAddr
   void $ upsertBy (UniqueUserCompany uid cid) 
                   (UserCompany uid cid False False) 
                   []
   superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] []
-  upsertManyWhere [ UserSupervisor super uid reroute 
+  upsertManyWhere [ UserSupervisor super uid reroute (Just cid) Nothing
                   | Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs
                   ] [] [] []
 upsertUserCompany uid _ _ = 

src/Handler/Utils/Users.hs

@@ -859,9 +859,15 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       return $ UserSupervisor
         E.<#  E.val newUserId
         E.<&> (userSupervisor E.^. UserSupervisorUser)
-        E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)        
+        E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
+        E.<&> (userSupervisor E.^. UserSupervisorCompany)
+        E.<&> (userSupervisor E.^. UserSupervisorReason)
     )
-    (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)  ] )
+    (\current excluded -> 
+        [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)  
+        , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] 
+        , UserSupervisorReason  E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] 
+        ] )
   deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
 
   E.insertSelectWithConflict
@@ -872,8 +878,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
         E.<#  (userSupervisor E.^. UserSupervisorSupervisor)
         E.<&> E.val newUserId
         E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
+        E.<&> (userSupervisor E.^. UserSupervisorCompany)
+        E.<&> (userSupervisor E.^. UserSupervisorReason)
     )
-    (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)  ] )
+    (\current excluded -> 
+        [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
+        , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] 
+        , UserSupervisorReason  E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] 
+        ] )
   deleteWhere [ UserSupervisorUser ==. oldUserId]
 
   -- Companies, in conflict, keep the newUser-Company as is

src/Model/Migration/Definitions.hs

@@ -48,7 +48,8 @@ import qualified Data.Time.Zones as TZ
 
 data ManualMigration
   = Migration20230524QualificationUserBlock
-  | Migration20230703LmsUserStatus
+  | Migration20230703LmsUserStatus  
+  | Migration20240124UniquenessCompanyAvsNr
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -97,7 +98,7 @@ migrateManual = do
     , ("idx_user_avs_card_person_id"         ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")")
     , ("idx_lms_report_log_q_ident_time"     ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")")
     , ("idx_user_company_company"            ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company
-    , ("idx_user_supervisor_user"            ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user
+    , ("idx_user_supervisor_user"            ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user    
     ]
   where
     addIndex :: Text -> Sql -> Migration
@@ -177,6 +178,14 @@ customMigrations = mapF $ \case
         ;  
       |]
 
+  Migration20240124UniquenessCompanyAvsNr ->
+    unlessM (indexExists "unique_company_avs_id") $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade
+      [executeQQ|
+        DELETE FROM "company" WHERE avs_id = 0;
+        ALTER TABLE "company" DROP CONSTRAINT IF EXISTS "unique_company_shorthand";
+      |]
+
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do
@@ -218,3 +227,10 @@ columnNotExists :: MonadIO m
              -> Text -- ^ Column
              -> ReaderT SqlBackend m Bool
 columnNotExists table column = and2M (tableExists table) (not <$> columnExists table column)
+
+indexExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
+indexExists ixName = do
+  res <- [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|] 
+  return $ case res of
+    [Single e]  -> e
+    _other      -> True

src/Model/Types/Avs.hs

@@ -593,9 +593,9 @@ instance ToJSON AvsFirmCommunication where
 derivePersistFieldJSON ''AvsFirmCommunication
 
 data AvsFirmInfo = AvsFirmInfo
-  { avsFirmFirm             :: Text
+  { avsFirmFirm             :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende!
   , avsFirmFirmNo           :: Int
-  , avsFirmAbbreviation     :: Text -- enthält manchmal Leerzeichen!
+  , avsFirmAbbreviation     :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende!
   , avsFirmZIPCode          :: Maybe Text
   , avsFirmCity             :: Maybe Text
   , avsFirmCountry          :: Maybe Text
@@ -629,9 +629,9 @@ _avsFirmPrimaryEmail = to mkEmail
 
 instance FromJSON AvsFirmInfo where
   parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo
-    <$> o .:   "Firm"
+    <$> (o .:  "Firm"         <&> Text.strip) -- AVS may contain leading/trailing whitespace
     <*> o .:   "FirmNo"
-    <*> o .:   "Abbreviation"
+    <*> (o .:  "Abbreviation" <&> Text.strip) -- AVS may contain leading/trailing whitespace
     <*> o .:?! "ZIPCode"
     <*> o .:?! "City"
     <*> o .:?! "Country"

src/Utils/Lens.hs

@@ -113,6 +113,8 @@ makeClassyFor_ ''User
 --   _user...
 --
 
+makeClassyFor_ ''UserSupervisor
+
 makeClassyFor_ ''StudyFeatures
 
 makeClassyFor_ ''StudyDegree

templates/profileData.hamlet

@@ -191,7 +191,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
                     ^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
 <section>
   <div .container>
-    $if hasRows
+    $if hasRowsOwnedCourses
       <div .container>
         <h2>_{MsgProfileCourses}
         <div .container>
@@ -243,4 +243,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
     \ _{MsgProfileCorrectorRemark}
     <a href=@{CorrectionsR}>_{MsgProfileCorrections}
 
+  <div .container>
+    <h2> _{MsgProfileSupervisor}
+    <div .container>
+      ^{supervisorsTable}
+
+  <div .container>
+    <h2> _{MsgProfileSupervisee}
+    <div .container>
+      ^{superviseesTable}
+
 ^{profileRemarks}

test/Database/Fill.hs

@@ -681,21 +681,21 @@ fillDb = do
   -- void . insert' $ UserSupervisor svaupel gkleen    False
   -- void . insert' $ UserSupervisor svaupel fhamann   True
   -- void . insert' $ UserSupervisor sbarth tinaTester True
-  let supvs = [ UserSupervisor jost gkleen       True
+  let supvs = [ UserSupervisor jost gkleen            True  (Just fraportAg)  (Just "Staff")
-              , UserSupervisor jost svaupel      False
+              , UserSupervisor jost svaupel           False (Just fraportAg)  (Just "Staff")
-              , UserSupervisor jost sbarth       False
+              , UserSupervisor jost sbarth            False (Just fraportAg)  (Just "Staff")
-              , UserSupervisor jost tinaTester   True
+              , UserSupervisor jost tinaTester        True  (Just fraportAg)  (Just "Staff")
-              , UserSupervisor jost jost         True
+              , UserSupervisor jost jost              True  (Just fraportAg)  (Just "Staff")
-              , UserSupervisor svaupel gkleen    False
+              , UserSupervisor svaupel gkleen         False (Just nice)       (Just "Staff")
-              , UserSupervisor svaupel fhamann   True
+              , UserSupervisor svaupel fhamann        True  (Just nice)       (Just "Staff")
-              , UserSupervisor sbarth tinaTester True
+              , UserSupervisor sbarth tinaTester      True  (Just nice)       (Just "Staff")
-              , UserSupervisor gkleen fhamann    False
+              , UserSupervisor gkleen fhamann         False (Just fraGround)  (Just "Staff")
-              , UserSupervisor gkleen gkleen     True
+              , UserSupervisor gkleen gkleen          True  (Just fraGround)  (Just "Staff")
-              , UserSupervisor tinaTester tinaTester False
+              , UserSupervisor tinaTester tinaTester  False Nothing           (Just "Staff")
               ] 
-              ++ take 444 [ UserSupervisor fhamann uid True  | Entity uid _ <-          matUsers, uid /= jost]
+              ++ take 444 [ UserSupervisor fhamann uid True  Nothing (Just "Test") | Entity uid _ <-          matUsers, uid /= jost]
-              ++ take 123 [ UserSupervisor gkleen  uid True  | Entity uid _ <- drop 369 matUsers ]
+              ++ take 123 [ UserSupervisor gkleen  uid True  (Just fraGround) (Just "Test") | Entity uid _ <- drop 369 matUsers ]
-              ++ take  11 [ UserSupervisor jost    uid False | Entity uid _ <- drop 501 matUsers ]
+              ++ take  11 [ UserSupervisor jost    uid False (Just fraportAg) (Just "Test") | Entity uid _ <- drop 501 matUsers ]
   upsertManyWhere supvs [] [] [] 
   -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok  
   -- insertMany_ supvs              -- NOTE: multiple calls like this throw an error!