fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(users): change supervisors in user list

Browse Source
This commit is contained in:
Steffen Jost 2023-01-13 19:04:36 +01:00
parent b503ced38f
commit 771bcd6993
14 changed files with 86 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/categories/courses/courses/de-de-formal.msg
View File

@ -83,7 +83,7 @@ CourseParticipantsRegisterHeading: Kursteilnehmer:innen hinzufügen
CourseParticipantsRegisterActionAddParticipants: Personen zum Kurs anmelden
CourseParticipantsRegisterActionAddTutorialMembers: Personen zu Kurs und Übungsgruppe anmelden
CourseParticipantsRegisterUsersField: Zum Kurs anzumeldende Personen
CourseParticipantsRegisterUsersFieldTip: Bitte Personalnummer angeben. Mehrere Personen bitte mit Komma getrennt angeben.
CourseParticipantsRegisterUsersFieldTip: Bitte Ausweiskartennummer inklusive Punkt, Fraport Personalnummer oder Email angeben. Mehrere Personen bitte mit Komma getrennt angeben.
CourseParticipantsRegisterTutorialOption: Kursteilnehmer:innen zu Übungsgruppe anmelden?
CourseParticipantsRegisterTutorialField: Übungsgruppe
CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Übungsgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Übungsgruppe mit diesem Namen vorhanden, werden die Kursteilnehmenden dieser hinzugefügt.

2
messages/uniworx/categories/courses/courses/en-eu.msg
View File

@ -83,7 +83,7 @@ CourseParticipantsRegisterHeading: Add course participants
CourseParticipantsRegisterActionAddParticipants: Add course participants
CourseParticipantsRegisterActionAddTutorialMembers: Add course and tutorial participants
CourseParticipantsRegisterUsersField: Persons to register for course
CourseParticipantsRegisterUsersFieldTip: Please enter personal number. Please separate multiple entries with commas.
CourseParticipantsRegisterUsersFieldTip: Please enter id card no (including dot), Fraport personnel number or email. Please separate multiple entries with commas.
CourseParticipantsRegisterTutorialOption: Register course participants for tutorial?
CourseParticipantsRegisterTutorialField: Tutorial
CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it.

4
messages/uniworx/categories/send/send_notifications/de-de-formal.msg
View File

@ -101,4 +101,6 @@ MailSupervisorBody undername@Text supername@Text: Sie erhalten diese Nachricht,
MailSupervisorCopy undermail@Text: Diese Nachricht ist eine Kopie einer Nachricht, welche an #{undermail} gesendet wurde.
MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eigentlichen Empfänger versandt! Für die Weiterleitung sind alle für diesen Empfänger in FRADrive eingetragenen Ansprechpartner verantwortlich!
MailSupervisedNote: Hinweis
MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet:
MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet:
MailSupervisorReroute: Benachrichtigungsumleitung
MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an alle Ansprechpartner mit Benachrichtigungsumleitung gesandt

4
messages/uniworx/categories/send/send_notifications/en-eu.msg
View File

@ -101,4 +101,6 @@ MailSupervisorBody undername supername: You receive this message, since #{supern
MailSupervisorCopy undermail: This is a copy of a message originally sent to #{undermail}.
MailSupervisorNoCopy: Warning: This message was not sent to the original recipient! The FRADrive registered supervisor, i.e. you, is responsible for forwarding this message to the recipient!
MailSupervisedNote: Please note
MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely:
MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely:
MailSupervisorReroute: Reroute notifications
MailSupervisorRerouteTooltip: All notification will be sent to all supervisors with notification rerouting instead

4
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -93,4 +93,6 @@ UserSetSupervisor: Ansprechpartner ersetzen
AuthKindLDAP: Fraport AG Kennung
AuthKindPWHash: FRADrive Kennung
AuthKindNoLogin: Kein Login möglich
Name !ident-ok: Name
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 #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt. #{tshow bad} Ansprechpartner wurden nicht gefunden!

6
messages/uniworx/categories/user/en-eu.msg
View File

@ -15,7 +15,7 @@ AdminUserMatriculation: Matriculation
AdminUserSex: Sex
AdminUserTelephone: Phone
AdminUserMobile: Mobile
AdminUserFPersonalNumber: Personalnumber (Fraport AG only)
AdminUserFPersonalNumber: Personnel number (Fraport AG only)
AdminUserFDepartment: Department
AdminUserPostAddress: Postal Address
AdminUserPrefersPostal: Prefers postal letters over email
@ -93,4 +93,6 @@ UserSetSupervisor: Replace supervisors
AuthKindLDAP: Fraport AG account
AuthKindPWHash: FRADrive account
AuthKindNoLogin: No login
Name: Name
Name: Name
UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Supervisors for #{tshow usr} Users set
UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur #{tshow spr} Supervisors for #{tshow usr} Users set. #{tshow bad} Supervisors could not be identified!

4
src/Handler/Admin/Avs.hs
View File

@ -534,8 +534,8 @@ mkLicenceTable dbtIdent aLic apids = do
, if aLic == AvsNoLicence
then singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData
else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing
<$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
<*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
]
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST

4
src/Handler/Course/ParticipantInvite.hs
View File

@ -17,7 +17,6 @@ import qualified Data.Aeson as Aeson
import qualified Data.CaseInsensitive as CI
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Time.Zones as TZ
import qualified Data.Set as Set
@ -144,9 +143,6 @@ postCAddUserR tid ssh csh = do
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
let
cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text)
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList)
auReqUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
auReqTutorial <- optionalActionW
( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting

2
src/Handler/SAP.hs
View File

@ -53,7 +53,7 @@ instance ToNamedRecord SapUserTableCsv where
, "Ausprägung" Csv..= csvSUTausprägung
]
-- | Removes all elements containing Nothing, which should not be returend by the query anyway (only qualfications with sap id and users with internal personal number must be transmitted)
-- | Removes all elements containing Nothing, which should not be returend by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
-- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo
sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv]
sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l

45
src/Handler/Users.hs
View File

@ -15,6 +15,7 @@ import Jobs
import Handler.Utils
import Handler.Utils.Users
import Handler.Utils.Invitations
import Handler.Utils.Avs
import qualified Auth.LDAP as Auth
@ -63,10 +64,19 @@ embedRenderMessage ''UniWorX ''UserAction id
data UserActionData = UserLdapSyncData
| UserHijack
| UserAddSupervisorData
| UserSetSupervisorData
| UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool }
| UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
isNotSetSupervisor :: UserActionData -> Bool
isNotSetSupervisor UserSetSupervisorData{} = False
isNotSetSupervisor _ = True
isActionSupervisor :: UserActionData -> Bool
isActionSupervisor UserAddSupervisorData{} = True
isActionSupervisor UserSetSupervisorData{} = True
isActionSupervisor _ = False
data AllUsersAction = AllUsersLdapSync
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@ -175,9 +185,13 @@ postUsersR = do
acts :: Map UserAction (AForm Handler UserActionData)
acts = mconcat
[ singletonMap UserLdapSync $ pure UserLdapSyncData
, singletonMap UserAddSupervisor $ pure UserAddSupervisorData
, singletonMap UserSetSupervisor $ pure UserSetSupervisorData
[ singletonMap UserLdapSync $ pure UserLdapSyncData
, singletonMap UserAddSupervisor $ UserAddSupervisorData
<$> apopt (textField & cfCommaSeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
, singletonMap UserSetSupervisor $ UserSetSupervisorData
<$> apopt (textField & cfCommaSeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
]
over _1 postprocess <$> dbTable psValidator DBTable
@ -315,8 +329,8 @@ postUsersR = do
}
formResult usersRes $ \case
(_, usersSet)
| Set.null usersSet -> do
(act, usersSet)
| Set.null usersSet && isNotSetSupervisor act -> do
addMessageI Info MsgActionNoUsersSelected
redirect UsersR
(UserLdapSyncData, userSet) -> do
@ -325,6 +339,23 @@ postUsersR = do
redirect UsersR
(UserHijack, Set.minView -> Just (uid, _)) ->
hijackUser uid >>= sendResponse
(act, usersSet)
| isActionSupervisor act -> do
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser $ getActionSupervisors act
let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
users = Set.toList usersSet
nrSuperNotFound = length supersNotFound
runDB $ do
unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users]
putMany [UserSupervisor s u r
| let r = getActionRerouteNotifications act
, (_, Just s) <- supersFound
, u <- users
]
if nrSuperNotFound > 0
then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound
else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound)
redirect UsersR
_other -> error "Should not be possible"
((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm

4
src/Handler/Users/Add.hs
View File

@ -83,7 +83,7 @@ addNewUserNoNotfication :: AdminUserForm -> Handler (Maybe UserId)
addNewUserNoNotfication = addNewUser' False
addNewUser' :: Bool -> AdminUserForm -> Handler (Maybe UserId)
addNewUser' notifyusr AdminUserForm{..} = do
addNewUser' notifyUsr AdminUserForm{..} = do
now <- liftIO getCurrentTime
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
let
@ -128,7 +128,7 @@ addNewUser' notifyusr AdminUserForm{..} = do
runDBJobs . runMaybeT $ do
uid <- MaybeT $ insertUnique newUser
lift . queueDBJob $ JobSynchroniseLdapUser uid
when (notifyusr && aufAuth /= AuthNoLogin) $
when (notifyUsr && aufAuth /= AuthKindNoLogin) $
lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid (newUser ^. _userAuthentication)
when (aufAuth == AuthKindPWHash) $
lift . queueDBJob $ JobSendPasswordReset uid

18
src/Handler/Utils/Avs.hs
View File

@ -289,15 +289,21 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
-}
-- | Always update AVS Data
-- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Adress
upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
try (runDB $ ldapLookupAndUpsert otherId) >>= \case
Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now
_ -> return Nothing
other -> do -- attempt to recover by trying other ids
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
apid <- runDB . runMaybeT $ do
let someIdent = stripCI otherId
uid <- MaybeT (getKeyBy $ UniqueEmail someIdent)
<|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid)
ifMaybeM apid Nothing upsertAvsUserById
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
@ -373,7 +379,7 @@ upsertAvsUserById api = do
, aufPinPassword = userPin
, aufEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
, aufIdent = fakeIdent -- use AvsPersonId instead
, aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known
, aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
}
mbUid <- addNewUserNoNotfication newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
whenIsJust mbUid $ \uid -> runDB $ do

13
src/Utils/Avs.hs
View File

@ -13,7 +13,10 @@ import qualified Data.Text as Text
import Servant
import Servant.Client
#ifdef DEVELOPMENT
#else
import Servant.Client.Core (requestPath)
#endif
import Model.Types.Avs
@ -59,6 +62,14 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
#ifdef DEVELOPMENT
mkAvsQuery _ _ _ = AvsQuery
{ avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty
, avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
, avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty
}
#else
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv
, avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv
@ -72,7 +83,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404)))
| baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database!
catch404toEmpty other = other
#endif
-----------------------
-- Utility Functions --

6
src/Utils/Form.hs
View File

@ -27,6 +27,7 @@ import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Universe
import Data.List (nub, (!!))
import Data.Map.Lazy ((!))
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set
@ -46,8 +47,6 @@ import Control.Monad.Catch (MonadCatch)
import Control.Monad.Random.Class (uniform, uniformMay, getRandom, getRandomR, getRandomRs, weighted)
import Data.List (nub, (!!))
import Web.PathPieces
import Data.UUID hiding (toText)
@ -824,6 +823,9 @@ cfStrip = guardField (not . T.null . repack) . convertField (repack . T.strip .
cfCI :: (Functor m, CI.FoldCase s) => Field m s -> Field m (CI s)
cfCI = convertField CI.mk CI.original
cfCommaSeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.splitOn ",") (T.intercalate ", " . Set.toList)
isoField :: Functor m => AnIso' a b -> Field m a -> Field m b
isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso)