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
This commit is contained in:
parent
f40448cd31
commit
de45731a9b
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 )
|
||||
|
||||
|
||||
@ -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 _ _ =
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -113,6 +113,8 @@ makeClassyFor_ ''User
|
||||
-- _user...
|
||||
--
|
||||
|
||||
makeClassyFor_ ''UserSupervisor
|
||||
|
||||
makeClassyFor_ ''StudyFeatures
|
||||
|
||||
makeClassyFor_ ''StudyDegree
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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!
|
||||
|
||||
Loading…
Reference in New Issue
Block a user