From 61991aadc40fbbd24930b7e50c7e914c5a348a5e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Oct 2022 16:17:46 +0200 Subject: [PATCH] chore(avs): wip refactor qualifications view --- models/avs.model | 19 +++++++++++++++---- routes | 30 +++++++++++++++++------------- src/Auth/LDAP.hs | 4 +++- src/Handler/LMS.hs | 23 +++++++++++++++++++++-- src/Utils/Avs.hs | 1 + 5 files changed, 57 insertions(+), 20 deletions(-) diff --git a/models/avs.model b/models/avs.model index 5ce175d1a..c03fc538b 100644 --- a/models/avs.model +++ b/models/avs.model @@ -1,14 +1,25 @@ -- Tables to save data received AVS --- Purpose is to detect external changes in qualifications and postal addresses + +-- When creating an AvsUser the following cases are possible: +-- 1. User does not exist, hence a new UserId ought to be created. +-- 2. User does exists and can be matched by UserCompanyPersonalNumber +-- 3. User does exists but cannot be matched now :( +-- How can the matching be performed later? +-- Do we need to merge users? +-- > Handler.Utils.UsersassimilateUser + + UserAvs personId AvsPersonId -- unique identifier for user throughout avs - user UserId + user UserId UniqueUserAvsUser user - UniqueUserAvsId personId + UniqueUserAvsId personId deriving Generic +-- Multiple UserAvsCards per UserAvs is possible and not too uncommon. +-- Purpose of saving cards is to detect external changes in qualifications and postal addresses UserAvsCard - personId AvsPersonId + personId AvsPersonId cardNo AvsCardNo card AvsDataPersonCard lastSynch UTCTime diff --git a/routes b/routes index d1ec9cf1b..750a1703a 100644 --- a/routes +++ b/routes @@ -84,13 +84,17 @@ /external-apis ExternalApisR ServantApiExternalApis getServantApi -/user ProfileR GET POST !free -/user/profile ProfileDataR GET !free -/user/authpreds AuthPredsR GET POST !free -/user/set-display-email SetDisplayEmailR GET POST !free -/user/csv-options CsvOptionsR GET POST !free -/user/lang LangR POST !free -/user/storage-key StorageKeyR POST !free +/user ProfileR GET POST !free +/user/profile ProfileDataR GET !free +/user/authpreds AuthPredsR GET POST !free +/user/set-display-email SetDisplayEmailR GET POST !free +/user/csv-options CsvOptionsR GET POST !free +/user/lang LangR POST !free +/user/storage-key StorageKeyR POST !free + +-- /user/for/#CryptoUUIDUser ForProfileR GET POST !supervisor +-- /user/profile/for/#CryptoUUIDUser ForProfuleDataR GET !supervisor + /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office @@ -265,13 +269,13 @@ -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -- for users -/qualification QualificationAllR GET !free -/qualification/#SchoolId QualificationSchoolR GET !free -- TODO -/qualification/#SchoolId/#QualificationShorthand QualificationR GET -- TODO make !free again after repurpose +/qualification QualificationAllR GET !free -- TODO repurpose +/qualification/#SchoolId QualificationSchoolR GET !free -- TODO repurpose +/qualification/#SchoolId/#QualificationShorthand QualificationR GET !free -- TODO repurpose -- OSIS CSV Export Demo -/lms LmsAllR GET POST -/lms/#SchoolId LmsSchoolR GET -/lms/#SchoolId/#QualificationShorthand LmsR GET POST +/lms LmsAllR GET POST !free -- TODO verify that this is ok +/lms/#SchoolId LmsSchoolR GET !free -- TODO verify that this is ok +/lms/#SchoolId/#QualificationShorthand LmsR GET POST !free -- TODO verify that this is ok /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET /lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 1990b40a3..2bfc7587c 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -59,8 +59,10 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM [ ldapUserEmail' Ldap.:= Text.encodeUtf8 ident' | ident' <- [ident, [st|#{ident}@lmu.de|], [st|#{ident}@fraport.de|]] , ldapUserEmail' <- toList ldapUserEmail + -- ] ++ + -- [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident -- for Fraport, userDisplayName has the pattern "Surname, Firstnames" ] ++ - [ ldapUserDisplayName Ldap.:= Text.encodeUtf8 ident + [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident ] findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 116d864e0..d75ed1010 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -324,6 +324,14 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.Left return (qualUser, user, lmsUser, printJob) +newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool } + +instance Default LmsTableFilterProj where + def = LmsTableFilterProj + { ltProjFilterMayAccess = Nothing } + +makeLenses_ ''LmsTableFilterProj + mkLmsTable :: forall h p cols act act'. ( Functor h, ToSortable h , Ord act, PathPiece act, RenderMessage UniWorX act @@ -347,7 +355,17 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do dbtIdent = "qualification" dbtSQLQuery q = lmsTableQuery qid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjFilteredPostId + --dbtProj = dbtProjFilteredPostId + dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do + qusr <- view $ _dbtProjRow . resultQualUser + user <- view $ _dbtProjRow . resultUser + lusr <- preview $ _dbtProjRow . resultLmsUser + pjob <- preview $ _dbtProjRow . resultPrintJob + forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do + euid <- encrypt $ user ^. _entityKey + guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ AdminUserR euid -- TODO create a page with proper rights; this is only for admins! + return (qusr,user,lusr,pjob) + dbtColonnade = cols dbtSorting = mconcat [ single $ sortUserNameLink queryUser @@ -367,7 +385,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do , single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded)) ] dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUser + [ single ("may-access" , FilterProjected $ (_ltProjFilterMayAccess ?~) . getAny) + , single $ fltrUserNameEmail queryUser , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) -- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 15b65b39a..6799ac701 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -128,6 +128,7 @@ bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering compareBy f = compare `on` f a b -} +-- Merges several answers by AvsPersonId, preserving all AvsPersonCards mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson mergeByPersonId = flip $ Set.foldr aux where