chore(users): change supervisors in user list

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

@@ -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.

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

@@ -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.

messages/uniworx/categories/send/send_notifications/de-de-formal.msg

@@ -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

messages/uniworx/categories/send/send_notifications/en-eu.msg

@@ -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

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

@@ -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!

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

@@ -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!

src/Handler/Admin/Avs.hs

@@ -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
+                    <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid
-                    <*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing
+                    <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?!
           ]      
       dbtParams = DBParamsForm
           { dbParamsFormMethod = POST

src/Handler/Course/ParticipantInvite.hs

@@ -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

src/Handler/SAP.hs

@@ -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 

src/Handler/Users.hs

@@ -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
+                    | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } 
-                    | UserSetSupervisorData
+                    | 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 UserLdapSync      $ pure UserLdapSyncData
-        , singletonMap UserAddSupervisor $ pure UserAddSupervisorData
+        , singletonMap UserAddSupervisor $ UserAddSupervisorData 
-        , singletonMap UserSetSupervisor $ pure UserSetSupervisorData
+            <$> 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)
+    (act, usersSet)
-      | Set.null usersSet -> do
+      | 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

src/Handler/Users/Add.hs

@@ -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

src/Handler/Utils/Avs.hs

@@ -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
+    other -> do -- attempt to recover by trying other ids
-    _ -> return Nothing
+      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

src/Utils/Avs.hs

@@ -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 --

src/Utils/Form.hs

@@ -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)