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

Merge branch 'fradrive/cr3'

Browse Source
This commit is contained in:
Steffen Jost 2024-06-12 17:51:15 +02:00
commit ad8e67dab1
23 changed files with 200 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
config/settings.yml
View File

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

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

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

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

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

2
messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg
View File

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

2
messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg
View File

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

1
messages/uniworx/utils/table_column/de-de-formal.msg
View File

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

1
messages/uniworx/utils/table_column/en-eu.msg
View File

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

2
models/company.model
View File

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

8
routes
View File

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

16
src/Foundation/Navigation.hs
View File

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

2
src/Handler/Admin.hs
View File

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

38
src/Handler/Firm.hs
View File

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

18
src/Handler/Profile.hs
View File

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

40
src/Handler/Users.hs
View File

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

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

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

13
src/Handler/Utils/Company.hs
View File

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

6
src/Handler/Utils/Form.hs
View File

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

15
src/Handler/Utils/Table/Columns.hs
View File

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

10
src/Handler/Utils/Users.hs
View File

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

5
src/Handler/Utils/Widgets.hs
View File

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

2
src/Model/Types/Avs.hs
View File

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

2
src/Settings.hs
View File

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

9
templates/adminUser.hamlet
View File

@ -20,7 +20,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgAdminUserAssimilate}
^{assimilateForm}
$# <section>
$# <p>
$# _{MsgUserAccountDeleteWarning}
$# <p>
$# ^{modal "Benutzer löschen" (Right deleteWidget)}
$# <h3 .show-hide__toggle uw-show-hide data-show-hide-collapsed>
$# _{MsgUserAccountDeleteWarning}
$# <div>
$# <p>
$# ^{modal _{MsgBreadcrumbUserDelete} (Right deleteWidget)}