Merge branch 'fradrive/cr3'

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

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}

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

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

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

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

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

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

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                AdminUserR       GET POST
-/users/#CryptoUUIDUser/delete AdminUserDeleteR     POST
+/users/#CryptoUUIDUser/delete         AdminUserDeleteR     POST
-/users/#CryptoUUIDUser/hijack AdminHijackUserR GET POST       !adminANDno-escalation
+/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

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 (AdminUserDeleteR    cID) = i18nCrumb MsgBreadcrumbUserDelete  . Just $ AdminUserR cID
-breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
+breadcrumb (AdminUserSyncLdapR  cID) = i18nCrumb MsgBreadcrumbSynchLdap   . Just $ AdminUserR cID
-breadcrumb (UserNotificationR cID) = useRunDB $ do
+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

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

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)

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

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
+      n <- runDB $ queueAvsUpdateByUID userSet Nothing
-      addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
+      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
+    AllUsersAvsSync -> do      
-      nowaday <- liftIO getCurrentTime <&> utctDay
+      now <- liftIO getCurrentTime
-      n <- runDB $ Ex.insertSelectCount $ do
+      let nowaday = utctDay now
-        usr <- Ex.from $ Ex.table @User
+      n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser
-        return (AvsSync
+        ( do
-            Ex.<#  (usr Ex.^. UserId)
+            usr <- Ex.from $ Ex.table @User
-            Ex.<&> E.now_
+            return (AvsSync
-            -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
+                Ex.<#  (usr Ex.^. UserId)
-            Ex.<&> E.justVal nowaday
+                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")
 
 

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 ()
+queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> DB Int64
-queueAvsUpdateByUID uids pause = do
+queueAvsUpdateByAID aids = queueAvsUpdateAux (E.table @UserAvs) (E.^. UserAvsUser) (\usrAvs -> usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids)
-  now <- liftIO getCurrentTime
-  runDB $ putMany [AvsSync uid now pause | uid <- toList uids]
-  queueJob' JobSynchroniseAvsQueue
 
-queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> Handler ()
+-- 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
-queueAvsUpdateByAID aids pause = do
+queueAvsUpdateAux :: E.From t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64
-  now <- liftIO getCurrentTime
+queueAvsUpdateAux tbl prj fltr pause = do 
-  runDB $ do
+  now <- liftIO getCurrentTime  
-    uids <- E.select $ do
+  n <- E.insertSelectWithConflictCount UniqueAvsSyncUser
-      usrAvs <- E.from $ E.table @UserAvs
+        ( do
-      E.where_ $ usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids
+            usr <- E.from tbl
-          -- E.&&. (E.isNothing pause E.||. pause E.>. E.dayMaybe (usrAvs  E.?. UserAvsLastSynch))   -- pause is checked later on in JobSynchroniseAvsQueue
+            E.where_ $ fltr usr
-      return $ usrAvs E.^. UserAvsUser
+            return (AvsSync E.<# prj usr E.<&> E.val now E.<&> E.val pause)
-    putMany [AvsSync uid now pause | E.Value uid <- uids]
+        ) (\current excluded -> 
-  queueJob' JobSynchroniseAvsQueue
+            [ 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; 

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))
+        usrPostUp = toMaybe (usrPostEmailUpds && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
-                      (UserPostAddress =. Nothing)                                                   -- use company address indirectyl instead
+                      (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

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
 

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

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
+  | (Just upo) <- userPostAddress, validPostAddress userPostAddress
-    = prefixMarkupName pa
+    = 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
+        let auto = userPostAddress == muavs ^? _Just . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just -- Recall: using _Just with ^. on Nothing yields mempty
-        return (res, auto)        
+        return (userPostAddress, auto)        
   | otherwise
     = do
         getUserPrimaryCompanyAddress uid companyPostAddress >>= \case

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

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?

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"

templates/adminUser.hamlet

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