diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index a3c630c46..573892220 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/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 \ No newline at end of file diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 10c42830d..43bc1bf85 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/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"}. \ No newline at end of file +UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. +SupervisorReason: Reason \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 0a67481af..43031fd5b 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index e7ae23a14..8546022d9 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/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 diff --git a/models/company.model b/models/company.model index 811af197d..422a7a14d 100644 --- a/models/company.model +++ b/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 - -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id - Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } + -- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already + UniqueCompanyAvsId avsId + Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } deriving Ord Eq Show Generic Binary -- TODO: a way to populate this table (manually) diff --git a/models/users.model b/models/users.model index 7ee24e9fb..ad7b20c00 100644 --- a/models/users.model +++ b/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 - UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once) + rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well + 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 diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5067c38ed..0d68a958f 100644 --- a/src/Handler/Firm.hs +++ b/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: -deleteSupervisors :: NonEmpty UserId -> DB Int64 -deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs] +-- | remove supervisors for given users; maybe restricted to those linked to a given companies +deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64 +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 - <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers] + $ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep + <* 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 diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index cd7392760..d1b876db6 100644 --- a/src/Handler/LMS/Fake.hs +++ b/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 suid suid True - 3 -> void $ insertBy $ UserSupervisor s suid True + void $ insertBy $ UserSupervisor s suid True Nothing (Just "Test") + void $ insertBy $ UserSupervisor suid suid True Nothing Nothing + 3 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing _ -> return () _ -> \_ _ -> return () expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3a0103c58..e42a02bf0 100644 --- a/src/Handler/Profile.hs +++ b/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 diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2af62ef7d..8ff0bd673 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -64,8 +64,8 @@ embedRenderMessage ''UniWorX ''UserAction id data UserActionData = UserLdapSyncData | UserHijack - | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } - | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } + | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } + | 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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 90c3a3c0f..2d7cc6686 100644 --- a/src/Handler/Utils/Avs.hs +++ b/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_new = (oldAvsFirmInfo ^. _avsFirmFirmNo) + -- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo) + -- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo) + -- in -- cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm ) -- cmp_new = (oldAvsFirmInfo ^. _avsFirmFirm ) diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 440f6c8fa..034ce56e1 100644 --- a/src/Handler/Utils/Company.hs +++ b/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 _ _ = diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 223f58f28..4cd40a063 100644 --- a/src/Handler/Utils/Users.hs +++ b/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 diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 8e458ac47..4cc026a76 100644 --- a/src/Model/Migration/Definitions.hs +++ b/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 diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 63fb8cf53..a81cdc33d 100644 --- a/src/Model/Types/Avs.hs +++ b/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" diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 5e5f993c6..e31590b44 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -113,6 +113,8 @@ makeClassyFor_ ''User -- _user... -- +makeClassyFor_ ''UserSupervisor + makeClassyFor_ ''StudyFeatures makeClassyFor_ ''StudyDegree diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 9eb2817af..8ab2bf8dd 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -191,7 +191,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
- $if hasRows + $if hasRowsOwnedCourses

_{MsgProfileCourses}
@@ -243,4 +243,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later \ _{MsgProfileCorrectorRemark} _{MsgProfileCorrections} +
+

_{MsgProfileSupervisor} +
+ ^{supervisorsTable} + +
+

_{MsgProfileSupervisee} +
+ ^{superviseesTable} + ^{profileRemarks} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 743c27e96..cecba6f38 100644 --- a/test/Database/Fill.hs +++ b/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 - , UserSupervisor jost svaupel False - , UserSupervisor jost sbarth False - , UserSupervisor jost tinaTester True - , UserSupervisor jost jost True - , UserSupervisor svaupel gkleen False - , UserSupervisor svaupel fhamann True - , UserSupervisor sbarth tinaTester True - , UserSupervisor gkleen fhamann False - , UserSupervisor gkleen gkleen True - , UserSupervisor tinaTester tinaTester False + let supvs = [ UserSupervisor jost gkleen True (Just fraportAg) (Just "Staff") + , UserSupervisor jost svaupel False (Just fraportAg) (Just "Staff") + , UserSupervisor jost sbarth False (Just fraportAg) (Just "Staff") + , UserSupervisor jost tinaTester True (Just fraportAg) (Just "Staff") + , UserSupervisor jost jost True (Just fraportAg) (Just "Staff") + , UserSupervisor svaupel gkleen False (Just nice) (Just "Staff") + , UserSupervisor svaupel fhamann True (Just nice) (Just "Staff") + , UserSupervisor sbarth tinaTester True (Just nice) (Just "Staff") + , UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff") + , UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff") + , UserSupervisor tinaTester tinaTester False Nothing (Just "Staff") ] - ++ take 444 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost] - ++ take 123 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 369 matUsers ] - ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ] + ++ take 444 [ UserSupervisor fhamann uid True Nothing (Just "Test") | Entity uid _ <- matUsers, uid /= jost] + ++ take 123 [ UserSupervisor gkleen uid True (Just fraGround) (Just "Test") | Entity uid _ <- drop 369 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!