diff --git a/config/settings.yml b/config/settings.yml index bbe83979c..69e757c72 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -83,6 +83,7 @@ health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:1209600" # 14 Tage in Sekunden synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600" # jede Stunde +synchronise-ldap-users-expire: "_env:SYNCHRONISE_LDAP_EXPIRE:15897600" # halbes Jahr in Sekunden synchronise-avs-users-within: "_env:SYNCHRONISE_AVS_WITHIN:5702400" # alle 66 Tage synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6 Stunden diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index c7a92efb3..1caf455ef 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -48,6 +48,8 @@ FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört FilterForeignSupervisor: Hat firmenfremde Ansprechpartner FilterFirmExtern: Externe Firma +FilterFirmPrimary: Ist primäre Firma in FRADrive +FilterHasQualification: Hat Firmenangehörige mit aktuell gültiger Qualifikation FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 043312a20..0af0ef403 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -48,6 +48,8 @@ FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors FilterFirmExtern: External company +FilterFirmPrimary: Is primary company in FRADrive +FilterHasQualification: Has company associates with currently valid qualification FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 9087f1ca0..f58a0818d 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -151,3 +151,5 @@ BreadcrumbSubmissionAuthorshipStatements: Eigenständigkeitserklärungen BreadcrumbExternalApis: Externe APIs BreadcrumbApiDocs: API Dokumentation BreadcrumbSwagger !ident-ok: OpenAPI 2.0 (Swagger) +BreadcrumbSynchLdap !ident-ok: LDAP Synch +BreadcrumbSynchAvs !ident-ok: AVS Synch \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index 5763051d1..31a3c5016 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -151,3 +151,5 @@ BreadcrumbSubmissionAuthorshipStatements: Statements of Authorship BreadcrumbExternalApis: External APIs BreadcrumbApiDocs: API documentation BreadcrumbSwagger: OpenAPI 2.0 (Swagger) +BreadcrumbSynchLdap: Synch LDAP +BreadcrumbSynchAvs: Synch AVS diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 43031fd5b..03d31eace 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -73,6 +73,7 @@ TableDiffDaysTooltip: Zeitspanne nach ISO 8601. Beispiel: "P2Y3M4D" ist eine Zei TableExamOfficeLabel: Label-Name TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität +TableQualification: Qualifikation TableQualifications: Qualifikationen TableCompany: Firma TableCompanyFilter: Firma oder Nummer diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 8546022d9..0dacc0a75 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -73,6 +73,7 @@ TableDiffDaysTooltip: Duration given according to ISO 8601. Example: "P2Y3M4D" i TableExamOfficeLabel: Label name TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority +TableQualification: Qualification TableQualifications: Qualifications TableCompany: Company TableCompanyFilter: Company/Nr diff --git a/models/company.model b/models/company.model index 4ed5274e1..ae94849e8 100644 --- a/models/company.model +++ b/models/company.model @@ -5,7 +5,7 @@ -- Description of companies associated with users Company - name CompanyName -- == (CI Text) + name CompanyName -- == (CI Text) -- NOTE: Fraport department name may carry additional information; use the Shorthand with respect to UserCompanyDepartment 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, use negative numbers for non-AVS companies prefersPostal Bool default=false -- new company users prefers letters by post instead of email diff --git a/routes b/routes index 0585153a1..2224abd6f 100644 --- a/routes +++ b/routes @@ -52,9 +52,11 @@ / NewsR GET !free /users UsersR GET POST -- no tags, i.e. admins only -/users/#CryptoUUIDUser AdminUserR GET POST -/users/#CryptoUUIDUser/delete AdminUserDeleteR POST -/users/#CryptoUUIDUser/hijack AdminHijackUserR GET POST !adminANDno-escalation +/users/#CryptoUUIDUser AdminUserR GET POST +/users/#CryptoUUIDUser/delete AdminUserDeleteR POST +/users/#CryptoUUIDUser/hijack AdminHijackUserR GET POST !adminANDno-escalation +/users/#CryptoUUIDUser/sync/ldap AdminUserSyncLdapR GET +/users/#CryptoUUIDUser/sync/avs AdminUserSyncAvsR GET /users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self /users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash !/users/functionary-invite/new AdminNewFunctionaryInviteR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 008e68e08..3e97c43ee 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -87,9 +87,11 @@ breadcrumb (AdminUserR cID) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser $ J uid <- decrypt cID User{..} <- MaybeT $ get uid return (userDisplayName, Just UsersR) -breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID -breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID -breadcrumb (UserNotificationR cID) = useRunDB $ do +breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID +breadcrumb (AdminUserSyncLdapR cID) = i18nCrumb MsgBreadcrumbSynchLdap . Just $ AdminUserR cID +breadcrumb (AdminUserSyncAvsR cID) = i18nCrumb MsgBreadcrumbSynchAvs . Just $ AdminUserR cID +breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID +breadcrumb (UserNotificationR cID) = useRunDB $ do mayList <- hasReadAccessTo UsersR if | mayList @@ -1225,6 +1227,14 @@ pageActions (AdminUserR cID) = return , NavPageActionPrimary { navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLink MsgUserLdapSync $ AdminUserSyncLdapR cID + , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLink MsgUserAvsSync $ AdminUserSyncAvsR cID + , navChildren = [] } , NavPageActionPrimary { navLink = defNavLinkModal MsgUserHijack $ AdminHijackUserR cID diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 53c5d6116..f15ddd5aa 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -95,7 +95,7 @@ handleAdminProblems mbProblemTable = do (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) (Right AvsLicenceDifferences{..}) -> do let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld - queueAvsUpdateByAID problemIds $ Just nowaday + void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday return $ Right ( Set.size avsLicenceDiffRevokeAll , Set.size avsLicenceDiffGrantVorfeld diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 32655b867..23d5acc21 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -464,7 +464,7 @@ resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do - -- now <- liftIO getCurrentTime + now <- liftIO getCurrentTime mr <- getMessageRender let resultDBTable = DBTable{..} @@ -701,6 +701,16 @@ mkFirmAllTable isAdmin uid = do Just False -> E.notExists checkSuper ) , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) + , single ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do + (usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany + `E.innerJoin` E.table @QualificationUser + `E.on` (\(usrCmp :& usrQual) -> usrCmp E.^. UserCompanyUser E.==. usrQual E.^. QualificationUserUser) + `E.innerJoin` E.table @Qualification + `E.on` (\(_ :& usrQual :& qual) -> qual E.^. QualificationId E.==. usrQual E.^. QualificationUserQualification) + E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. qual E.^. QualificationShorthand E.==. E.val criterion + E.&&. validQualification now usrQual + ) ] dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev @@ -711,6 +721,7 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "is-default-supervisor") mPrev $ aopt textField (fslI MsgFirmSuperDefault) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) + , fltrQualificationHdrUI MsgFilterHasQualification mPrev ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = DBParamsForm @@ -796,7 +807,7 @@ queryUserUser = $(sqlIJproj 2 1) queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany) queryUserUserCompany = $(sqlIJproj 2 2) -type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) +type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) -- , E.Value Bool) resultUserUser :: Lens' UserCompanyTableData (Entity User) resultUserUser = _dbrOutput . _1 @@ -810,6 +821,9 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue +-- resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool +-- resultUserCompanyPrimary = _dbrOutput . _5 . _unValue + instance HasEntity UserCompanyTableData User where hasEntity = resultUserUser @@ -837,20 +851,24 @@ mkFirmUserTable isAdmin cid = do (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid) E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) - E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) let -- supervisorField :: Field Handler UserId -- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers - fsh = unCompanyKey cid resultDBTable = DBTable{..} where dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid + -- let isPrimary = E.notExists (do + -- other <- E.from $ E.table @UserCompany + -- E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser + -- E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority + -- ) return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp) dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId @@ -928,15 +946,25 @@ mkFirmUserTable isAdmin cid = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria + , singletonMap "is-primary-company" $ FilterColumn $ \row (getLast -> criterion) -> + let checkPrimary = do + other <- E.from $ E.table @UserCompany + E.where_ $ other E.^. UserCompanyUser E.==. queryUserUserCompany row E.^. UserCompanyUser + E.&&. other E.^. UserCompanyPriority E.>. queryUserUserCompany row E.^. UserCompanyPriority + in case criterion of + Nothing -> E.true + Just False -> E.exists checkPrimary + Just True -> E.notExists checkPrimary ] -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip) - , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) + , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) + , prismAForm (singletonFilter "is-primary-company" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPrimary) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 7defa02c9..0515e8daa 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -14,11 +14,14 @@ module Handler.Profile , getSetDisplayEmailR, postSetDisplayEmailR , getCsvOptionsR, postCsvOptionsR , postLangR + , getAdminUserSyncAvsR + , getAdminUserSyncLdapR ) where import Import import Handler.Utils +import Handler.Utils.Avs import Handler.Utils.Profile import Handler.Utils.Users import Handler.Utils.Company @@ -1255,3 +1258,18 @@ postLangR = do addMessage Success . toHtml $ mr MsgLanguageChanged redirect . fromMaybe NewsR =<< lookupGlobalGetParam GetReferer + + +getAdminUserSyncLdapR :: CryptoUUIDUser -> Handler Html +getAdminUserSyncLdapR uuid = do + uid <- decrypt uuid + queueJob' $ JobSynchroniseLdapUser uid + addMessageI Success $ MsgSynchroniseLdapUserQueued 1 + redirectUltDest $ AdminUserR uuid + +getAdminUserSyncAvsR :: CryptoUUIDUser -> Handler Html +getAdminUserSyncAvsR uuid = do + uid <- decrypt uuid + n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing + addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n + redirectUltDest $ AdminUserR uuid diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 5b3701cf2..9d9f8ad82 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -62,19 +62,20 @@ hijackUserForm = \csrf -> do -- instance HasUser (DBRow (Entity USer)) where -- hasUser = _entityVal -data UserAction = UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserAvsSync +data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) nullaryPathPiece ''UserAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAction id -data UserActionData = UserLdapSyncData +data UserActionData = UserAvsSyncData + | UserLdapSyncData | UserHijack | 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) isNotSetSupervisor :: UserActionData -> Bool @@ -369,8 +370,8 @@ postUsersR = do addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserAvsSyncData, userSet) -> do - queueAvsUpdateByUID userSet Nothing - addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet + n <- runDB $ queueAvsUpdateByUID userSet Nothing + addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n redirectKeepGetParams UsersR (UserHijack, Set.lookupMin -> Just uid) -> hijackUser uid >>= sendResponse @@ -404,16 +405,23 @@ postUsersR = do runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) addMessageI Success MsgSynchroniseLdapAllUsersQueued redirect UsersR - AllUsersAvsSync -> do - nowaday <- liftIO getCurrentTime <&> utctDay - n <- runDB $ Ex.insertSelectCount $ do - usr <- Ex.from $ Ex.table @User - return (AvsSync - Ex.<# (usr Ex.^. UserId) - Ex.<&> E.now_ - -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock - Ex.<&> E.justVal nowaday - ) + AllUsersAvsSync -> do + now <- liftIO getCurrentTime + let nowaday = utctDay now + n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser + ( do + usr <- Ex.from $ Ex.table @User + return (AvsSync + Ex.<# (usr Ex.^. UserId) + Ex.<&> E.val now + -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock + Ex.<&> E.justVal nowaday + ) + ) (\current excluded -> + [ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime) + , AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause) + ] + ) queueJob' JobSynchroniseAvsQueue addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n redirect UsersR @@ -659,7 +667,7 @@ postAdminUserR uuid = do } userDataWidget <- runDB $ makeProfileData $ Entity uid user siteLayout heading $ do - let _deleteWidget = $(i18nWidgetFile "data-delete") + let _deleteWidget = $(i18nWidgetFile "data-delete") -- TODO: update deletion text for FRADrive $(widgetFile "adminUser") diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index f115de106..518a6caed 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -61,7 +61,7 @@ import Handler.Utils.Memcached import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E --- import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.PostgreSQL as E import Servant.Client.Core.ClientError (ClientError) @@ -329,19 +329,40 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa let usrId = userAvsUser usravs usr <- MaybeT $ get usrId lift $ do -- maybeT no longer needed from here onwards - newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw - now <- liftIO getCurrentTime let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing is ok here oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here oldAvsCardNo = userAvsLastCardNo usravs & fmap Just - per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) + newAvsCardNo <- queryAvsFullCardNo apid -- Nothing os ok here, does not throw + now <- liftIO getCurrentTime + mbLdapExpire <- getsYesod $ views appSettings appSynchroniseLdapUsersExpire + ldap_ups <- if | Just ldapExpire <- mbLdapExpire + , maybe True (\lastLdapSync -> now > addUTCTime ldapExpire lastLdapSync) (userLastLdapSynchronisation usr) + , Just udep <- userCompanyDepartment usr + , let aipn = newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo + depKey = CompanyKey $ stripCI udep -- Shorthand is returned by LDAP + -> do -- LDAP sync invalid/expired + usrComp <- getBy $ UniqueUserCompany usrId depKey + whenIsJust usrComp $ \Entity{entityKey=ucKey, entityVal=UserCompany{userCompanySupervisor=isSuper, userCompanySupervisorReroute=rroute}} -> do + delete ucKey + when isSuper $ reportAdminProblem $ AdminProblemSupervisorLeftCompany usrId depKey rroute + return [ UserCompanyDepartment =. Nothing + , UserCompanyPersonalNumber =. aipn + , UserLdapPrimaryKey =. aipn + ] + | otherwise + -> return $ mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) $ + bcons (isJust $ newAvsPersonInfo ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo) + ( CheckUpdate UserLdapPrimaryKey $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just) + [ CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just + ] + let per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) [ CheckUpdate UserFirstName _avsInfoFirstName , CheckUpdate UserSurname _avsInfoLastName , CheckUpdate UserDisplayName _avsInfoDisplayName , CheckUpdate UserBirthday _avsInfoDateOfBirth , CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo , CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - , CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo + -- , CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo; needs special treatment, see ldap_ups above ] apiEmail = _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI afiEmail = _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI @@ -360,14 +381,15 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa CheckUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just - usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups)) + usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` (ldap_ups <> per_ups))) avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing , UserAvsLastPersonInfo =. Just newAvsPersonInfo , UserAvsLastFirmInfo =. Just newAvsFirmInfo , UserAvsLastCardNo =. newAvsCardNo - ] + ] + -- update company association & supervision Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo @@ -640,24 +662,28 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do ] +queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64 +queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User) (E.^. UserId) (\usr -> usr E.^. UserId `E.in_` E.vals uids) -queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler () -queueAvsUpdateByUID uids pause = do - now <- liftIO getCurrentTime - runDB $ putMany [AvsSync uid now pause | uid <- toList uids] - queueJob' JobSynchroniseAvsQueue +queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> DB Int64 +queueAvsUpdateByAID aids = queueAvsUpdateAux (E.table @UserAvs) (E.^. UserAvsUser) (\usrAvs -> usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids) -queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> Handler () -queueAvsUpdateByAID aids pause = do - now <- liftIO getCurrentTime - runDB $ do - uids <- E.select $ do - usrAvs <- E.from $ E.table @UserAvs - E.where_ $ usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids - -- E.&&. (E.isNothing pause E.||. pause E.>. E.dayMaybe (usrAvs E.?. UserAvsLastSynch)) -- pause is checked later on in JobSynchroniseAvsQueue - return $ usrAvs E.^. UserAvsUser - putMany [AvsSync uid now pause | E.Value uid <- uids] - queueJob' JobSynchroniseAvsQueue +-- queueAvsUpdateAux :: E.From (E.SqlExpr (Entity ent)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value UserId)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64 +queueAvsUpdateAux :: E.From t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64 +queueAvsUpdateAux tbl prj fltr pause = do + now <- liftIO getCurrentTime + n <- E.insertSelectWithConflictCount UniqueAvsSyncUser + ( do + usr <- E.from tbl + E.where_ $ fltr usr + return (AvsSync E.<# prj usr E.<&> E.val now E.<&> E.val pause) + ) (\current excluded -> + [ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime) + , AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause) + ] + ) + runDBJobs' $ queueDBJob JobSynchroniseAvsQueue + return n -- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 634bf6143..82e4c34a4 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -78,20 +78,23 @@ addCompanySupervisors cid uid = -- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem]) -switchAvsUserCompany usrPostAddrUpd keepOldCompanySupervs uid newCompanyId = do +switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do usrRec <- get404 uid newCompany <- get404 newCompanyId mbUsrComp <- getUserPrimaryCompany uid mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp - mbUsrAvs <- if usrPostAddrUpd then getBy (UniqueUserAvsUser uid) else return Nothing + mbUsrAvs <- if usrPostEmailUpds then getBy (UniqueUserAvsUser uid) else return Nothing let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just - usrPostUp = toMaybe (usrPostAddrUpd && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr)) - (UserPostAddress =. Nothing) -- use company address indirectyl instead + usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr)) + (UserPostAddress =. Nothing) -- use company address indirectly instead usrPrefPost = userPrefersPostal usrRec usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) (UserPrefersPostal =. companyPrefersPostal newCompany) - usrUpdate = catMaybes [usrPostUp, usrPrefPostUp] + usrEmail :: UserEmail = userDisplayEmail usrRec + avsEmail :: Maybe UserEmail = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI + usrEmailUp = toMaybe (usrPostEmailUpds && avsEmail == Just usrEmail) (UserDisplayEmail =. "") + usrUpdate = catMaybes [usrPostUp, usrPrefPostUp, usrEmailUp] -- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional -- update uid usrUpdate -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index f992e76d8..9392ec58c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -594,6 +594,12 @@ degreeField = selectField $ optionsPersistKey [] [Asc StudyDegreeName, Asc Study degreeFieldEnt :: Field Handler (Entity StudyDegree) degreeFieldEnt = selectField $ optionsPersist [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id +qualificationField :: Field Handler QualificationId +qualificationField = selectField $ optionsPersistKey [] [Asc QualificationName] qualificationName + +qualificationFieldShort :: Field Handler QualificationShorthand +qualificationFieldShort = selectField $ (qualificationShorthand . entityVal) <<$>> optionsPersist [] [Asc QualificationName] qualificationName + qualificationFieldEnt :: Field Handler (Entity Qualification) qualificationFieldEnt = selectField $ optionsPersist [] [Asc QualificationName] qualificationName diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index b8f3cfff6..e04364f1e 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -470,6 +470,8 @@ fltrUserMatriclenrUI mPrev = ---------------- -- User E-Mail +---------------- + colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) colUserEmail = sortable (Just "user-email") (i18nCell MsgTableEmail) cellHasEMail @@ -719,6 +721,19 @@ fltrRelevantStudyFeaturesSemesterUI :: DBFilterUI fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI +-------------------- +-- Qualifications +-------------------- + +fltrQualification :: OpticFilterColumn t QualificationShorthand +fltrQualification queryQual = singletonMap "qualification" . FilterColumn $ mkExactFilter (view queryQual) + +fltrQualificationUI :: DBFilterUI +fltrQualificationUI = fltrQualificationHdrUI MsgTableQualification + +fltrQualificationHdrUI :: (RenderMessage UniWorX msg) => msg -> DBFilterUI +fltrQualificationHdrUI msg mPrev = prismAForm (singletonFilter "qualification" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift qualificationFieldShort) (fslI msg) + --------------- -- Companies -- diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 293dc4f7b..02e2fc173 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -152,8 +152,8 @@ getUserEmailAutomatic Entity{entityKey=uid, entityVal=User{userDisplayEmail, use -- address is prefixed with userDisplayName getPostalAddress :: Entity User -> DB (Maybe [Text]) getPostalAddress Entity{entityKey=uid, entityVal=User{..}} - | Just pa <- userPostAddress - = prefixMarkupName pa + | (Just upo) <- userPostAddress, validPostAddress userPostAddress + = prefixMarkupName upo | otherwise = do getUserPrimaryCompanyAddress uid companyPostAddress >>= \case @@ -170,11 +170,11 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}} -- primed variant returns storedMarkup without prefixed userDisplayName and whether updates are automatic getPostalAddress' :: Entity User -> DB (Maybe StoredMarkup, Bool) getPostalAddress' Entity{entityKey=uid, entityVal=User{..}} - | res@(Just upo) <- userPostAddress + | validPostAddress userPostAddress = do muavs <- getBy $ UniqueUserAvsUser uid - let auto = upo == muavs ^. _Just . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just -- Recall: _Just on Nothing yields mempty here - return (res, auto) + let auto = userPostAddress == muavs ^? _Just . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just -- Recall: using _Just with ^. on Nothing yields mempty + return (userPostAddress, auto) | otherwise = do getUserPrimaryCompanyAddress uid companyPostAddress >>= \case diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 3f6b1fe89..b56075a2c 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -38,7 +38,8 @@ visibleUTCTime dtf t = do -- | Simple link to a known route simpleLink :: HasRoute UniWorX url => Widget -> url -> Widget simpleLink lbl url = do - isAuth <- hasReadAccessTo $ urlRoute url + let route = urlRoute url + isAuth <- liftHandler . $cachedHereBinary route $ hasReadAccessTo route if | isAuth -> do tUrl <- toTextUrl url [whamlet| @@ -127,7 +128,7 @@ editedByW fmt tm usr = do -- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget modalAccess wdgtNo wdgtYes writeAccess route = do - authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route + authOk <- liftHandler . $cachedHereBinary (route, writeAccess) $ bool hasReadAccessTo hasWriteAccessTo writeAccess route if authOk then modal wdgtYes (Left $ SomeRoute route) else wdgtNo diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 0b0145ef0..7ab00ebc0 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -658,7 +658,7 @@ _avsFirmPrimaryEmail = to mkEmail mkEmail afi = let candidates = catMaybes [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail - , afi ^. _avsFirmEMailSuperior + , afi ^. _avsFirmEMailSuperior -- only set for Fraport departments, hence this is a non-personal department wide email suitable as company email , afi ^. _avsFirmEMail ] in pickValidEmail candidates -- should we return an invalid email rather than none? diff --git a/src/Settings.hs b/src/Settings.hs index 45738751e..10e929b65 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -164,6 +164,7 @@ data AppSettings = AppSettings , appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime , appSynchroniseLdapUsersInterval :: NominalDiffTime + , appSynchroniseLdapUsersExpire :: Maybe NominalDiffTime , appSynchroniseAvsUsersWithin :: Maybe NominalDiffTime , appSynchroniseAvsUsersInterval :: NominalDiffTime @@ -703,6 +704,7 @@ instance FromJSON AppSettings where appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within" appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval" + appSynchroniseLdapUsersExpire <- o .:? "synrchonise-ldap-users-expire" -- time after last synch to delete LDAP sepcific data appSynchroniseAvsUsersWithin <- o .:? "synchronise-avs-users-within" appSynchroniseAvsUsersInterval <- o .: "synchronise-avs-users-interval" diff --git a/templates/adminUser.hamlet b/templates/adminUser.hamlet index e483d6db4..1f51996e0 100644 --- a/templates/adminUser.hamlet +++ b/templates/adminUser.hamlet @@ -20,7 +20,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgAdminUserAssimilate} ^{assimilateForm} $#
-$#

-$# _{MsgUserAccountDeleteWarning} -$#

-$# ^{modal "Benutzer löschen" (Right deleteWidget)} +$#

+$# _{MsgUserAccountDeleteWarning} +$#
+$#

+$# ^{modal _{MsgBreadcrumbUserDelete} (Right deleteWidget)}