From b566e59eb1325485fe26dc4f0b5cb63165c58f74 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 21 Dec 2023 17:26:46 +0100 Subject: [PATCH 01/85] fix(firm): supervisor filter acts weird in test environment no cause discerned, test in dev evironment were all fine. Maybe the sorting assumption wasn't right? note other filters do not interfere with the memcaching in experiments --- src/Handler/Firm.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 596ea40c9..5067c38ed 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -599,7 +599,7 @@ mkFirmAllTable isAdmin uid = do case criterion of Nothing -> return True :: DB Bool (Just (crit::Text)) -> do - critFirms <- memcachedBy (Just . Right $ 5 * diffMinute) ("svr:"<>crit) $ fmap (Set.fromAscList . fmap E.unValue) $ E.select $ E.distinct $ do + critFirms <- memcachedBy (Just . Right $ 1 * diffMinute) ("SVR:"<>crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do (usr :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @Company `E.on` (\(usr :& cmp) -> E.exists (do usrCmp <- E.from $ E.table @UserCompany @@ -612,13 +612,13 @@ mkFirmAllTable isAdmin uid = do E.&&. E.exists (do usrSub <- E.from $ E.table @UserCompany E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser - E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId + E.&&. usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId ) )) - E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit) + E.where_ $ (usr E.^. UserDisplayName `E.hasInfix` E.val crit ) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit)) - E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit) - E.orderBy [E.asc $ cmp E.^. CompanyId] + E.||. (usr E.^. UserSurname `E.hasInfix` E.val crit ) + -- E.orderBy [E.asc $ cmp E.^. CompanyId] return $ cmp E.^. CompanyId let cid = dbr ^. resultAllCompanyEntity . _entityKey return $ Set.member cid critFirms -- 2.39.2 From 61aba7e515f5f855f35a36b95a210f802441f20a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 11 Jan 2024 19:23:35 +0100 Subject: [PATCH 02/85] updateAvsUser (partial) requires migration --- config/settings.yml | 4 +-- models/avs.model | 4 ++- src/Handler/Admin/Avs.hs | 4 +-- src/Handler/Utils/Avs.hs | 54 +++++++++++++++++++++++++++++++++++++--- src/Jobs/Handler/LMS.hs | 3 +-- src/Model/Types/Avs.hs | 22 +++++++++++----- src/Utils.hs | 5 ++++ src/Utils/Avs.hs | 18 +++++++------- src/Utils/DB.hs | 7 ++++++ 9 files changed, 95 insertions(+), 26 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 602c9c0e2..68bed4958 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -91,8 +91,8 @@ study-features-recache-relevance-within: 172800 study-features-recache-relevance-interval: 293 # Enqueue at specified hour, a few minutes later -# job-lms-qualifications-enqueue-hour: 15 -# job-lms-qualifications-dequeue-hour: 3 +job-lms-qualifications-enqueue-hour: 16 +job-lms-qualifications-dequeue-hour: 4 log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/models/avs.model b/models/avs.model index 7a8a59cc0..5147f382e 100644 --- a/models/avs.model +++ b/models/avs.model @@ -16,9 +16,11 @@ UserAvs personId AvsPersonId -- unique identifier for user throughout avs; newtype for Int user UserId - noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle + noPerson Int default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle, redundant since needed for filtering lastSynch UTCTime default=now() lastSynchError Text Maybe + lastPersonInfo AvsPersonInfo Maybe -- just to discern field changes + lastFirmInfo AvsFirmInfo Maybe -- just to discern field changes UniqueUserAvsUser user UniqueUserAvsId personId deriving Generic Show diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 9521912c9..871ee1634 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -740,7 +740,7 @@ getProblemAvsErrorR = do dbtSQLQuery (usravs `E.InnerJoin` user) = do E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError - return (usravs, user) + return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs) qerryUsrAvs = $(E.sqlIJproj 2 1) qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User) @@ -748,7 +748,7 @@ getProblemAvsErrorR = do reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs) reserrUsrAvs = _dbrOutput . _1 -- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User) - -- reserrUser = _dbrOutput . _2 + -- reserrUser = _dbrOutput . _2 dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 42275f139..9180ed5f4 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- Module for functions directly related to the AVS interface, -- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification @@ -417,14 +418,14 @@ upsertAvsUserById api = do $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] [] case candidates of - [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing) + [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing) -- TODO info (_:_) -> throwM $ AvsUserAmbiguous api [] -> do upsRes :: Either SomeException (Entity User) <- try $ ldapLookupAndUpsert persNo $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes case upsRes of - Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway + Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing -- pin/addr are updated in next step anyway -- TODO info Left err -> do $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err return mbuid -- == Nothing -- user could not be created somehow @@ -464,7 +465,7 @@ upsertAvsUserById api = do } mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe whenIsJust mbUid $ \uid -> runDB $ do - insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing + insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing Nothing Nothing -- TODO info forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard] -- forM_ cs $ -- only save used cards for the postal address update detection @@ -486,7 +487,7 @@ upsertAvsUserById api = do , UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo ] oldCards <- selectList [UserAvsCardPersonId ==. api] [] - let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards + let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards -- TODO: get rid of getCompanyAddress unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before encRecipient :: CryptoUUIDUser <- encrypt uid $logInfoS "AVS" $ "Postal address updated for" <> tshow encRecipient @@ -565,3 +566,48 @@ updateReceivers uid = do if null receivers then directResult else return (underling, receivers, uid `elem` (entityKey <$> receivers)) + + +------------------ +-- CR3 Functions + +updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) + => AvsPersonId -> m (Maybe UserId) +updateAvsUserById apid = do + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid + case Set.elems $ Set.filter ((== apid) . avsContactPersonID) adcs of + [] -> throwM AvsPersonSearchEmpty + (_:_:_) -> throwM AvsPersonSearchAmbiguous + [AvsDataContact _apid _avsPersonInfo _avsFirmInfo] -> do + return Nothing -- TODO + +updateAvsUserByIds :: Set AvsPersonId -> Handler (Set UserId) +updateAvsUserByIds apids = do + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids + foldMapM procResp adcs + where + procResp (AvsDataContact apid avsPersonInfo _avsFirmInfo) + | apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order) + | otherwise = runDB $ + getBy (UniqueUserAvsId apid) >>= continueJust ( \(Entity _ usravs) -> + let usrId = userAvsUser usravs in + get usrId >>= continueJust ( \usr -> do + let ups = mapMaybe (mkUpdate usr avsPersonInfo $ userAvsLastPersonInfo usravs) + [ (_avsInfoFirstName , UserFirstName ) + , (_avsInfoLastName , UserSurname ) + , (_avsInfoDisplayName, UserDisplayName) + -- , (_avsInfoDateOfBirth, UserBirthday ) -- not polymorphic enough, needs type annotation + ] + update usrId ups + return $ Set.singleton usrId + )) + mkUpdate usr npi (Just opi) (la, up) + | let newval = npi ^. la + , let oldval = opi ^. la + , let usrval = getField up usr + , oldval /= newval + , oldval == usrval + = Just (up =. newval) + mkUpdate _ _ _ _ = Nothing diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 763f46b39..b7af6db1b 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -60,7 +60,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act act = do quali <- getJust qid -- may throw an error, aborting the job let qshort = CI.original $ qualificationShorthand quali - $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort + $logInfoS "LMS" $ "Notifying about expiring qualification " <> qshort now <- liftIO getCurrentTime case qualificationRefreshWithin quali of Nothing -> return () -- TODO: no renewal period, no reminders currently @@ -129,7 +129,6 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act qprefix = fst <$> Text.uncons (Text.toLower qshort) identsInUseVs <- E.select $ do lui <- E.from $ - ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` ( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2 diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 997fa6588..debe9c26d 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -485,15 +485,24 @@ data AvsPersonInfo = AvsPersonInfo { avsInfoPersonNo :: Text -- Int -- AVS Personennummer, zum Gebrauch in menschlicher Kommunikation , avsInfoFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces , avsInfoLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces - , avsInfoRampLicence :: Int -- AvsLicence -- unlike other queries, may return -1 for guest unable to hold a licence; currently not distinquished from no licence + , avsInfoRampLicence :: Int -- AvsLicence -- unlike other queries, may return -1 for a guest unable to hold a licence; currently not distinquished from no licence , avsInfoDateOfBirth :: Maybe Day , avsInfoPersonEMail :: Maybe Text , avsInfoPersonMobilePhoneNo :: Maybe Text , avsInfoInternalPersonalNo :: Maybe AvsInternalPersonalNo -- Fraport Personalnummer - } deriving (Eq, Ord, Show, Generic) + } deriving (Eq, Ord, Show, Generic, NFData) makeLenses_ ''AvsPersonInfo +-- | Lens for a virtual DisplayName field. WARNING when used as Setter: Ambiguously the split into First- and LastName will always on the last word given. +_avsInfoDisplayName :: Lens' AvsPersonInfo Text +_avsInfoDisplayName = lens g s + where + g AvsPersonInfo{avsInfoFirstName, avsInfoLastName} = Text.append avsInfoFirstName $ Text.cons ' ' avsInfoLastName + s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn + in api{avsInfoFirstName = fn, avsInfoLastName = ln} + + instance FromJSON AvsPersonInfo where parseJSON = withObject "AvsPersonInfo" $ \o -> AvsPersonInfo <$> o .: "PersonsNo" -- NOTE: PersonsNo, not PersonNo as elsewhere @@ -518,7 +527,7 @@ instance ToJSON AvsPersonInfo where , "LastName" .= avsInfoLastName , "RampLicence" .= avsInfoRampLicence ] --- derivePersistFieldJSON ''AvsPersonInfo +derivePersistFieldJSON ''AvsPersonInfo data AvsFirmCommunication = AvsFirmCommunication @@ -527,7 +536,7 @@ data AvsFirmCommunication = AvsFirmCommunication , avsCommunicationCountry :: Maybe Text , avsCommunicationStreetANDHouseNo :: Maybe Text , avsCommunicationEMail :: Maybe Text - } deriving (Eq, Ord, Show, Generic) + } deriving (Eq, Ord, Show, Generic, NFData) instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where canonical (Just AvsFirmCommunication{..}) @@ -557,6 +566,7 @@ instance ToJSON AvsFirmCommunication where , ("StreetANDHouseNo" .=) <$> avsCommunicationStreetANDHouseNo & canonical , ("EMail" .=) <$> avsCommunicationEMail & canonical ] +derivePersistFieldJSON ''AvsFirmCommunication data AvsFirmInfo = AvsFirmInfo { avsFirmFirm :: Text @@ -569,7 +579,7 @@ data AvsFirmInfo = AvsFirmInfo , avsFirmEMail :: Maybe Text , avsFirmEMailSuperior :: Maybe Text , avsFirmCommunication :: Maybe AvsFirmCommunication - } deriving (Eq, Ord, Show, Generic) + } deriving (Eq, Ord, Show, Generic, NFData) makeLenses_ ''AvsFirmInfo @@ -600,7 +610,7 @@ instance ToJSON AvsFirmInfo where , "FirmNo" .= avsFirmFirmNo , "Abbreviation" .= avsFirmAbbreviation ] --- derivePersistFieldJSON ''AvsFirmInfo +derivePersistFieldJSON ''AvsFirmInfo data AvsDataContact = AvsDataContact diff --git a/src/Utils.hs b/src/Utils.hs index 2093da8b2..77c6bf59a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -904,6 +904,11 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () +-- | synonym for `flip foldMapM` +continueJust :: (Monoid m, Applicative f) => (a -> f m) -> Maybe a -> f m +continueJust f (Just x) = f x +continueJust _ Nothing = pure mempty + ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM ifMaybeM Nothing dft _ = return dft ifMaybeM (Just x) _ act = act x diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index c351243e8..7f6f0d696 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -114,18 +114,18 @@ splitQuery rawQuery q -- Utility Functions -- ----------------------- --- | retrieve AvsDataPersonCard with longest validity for a given licence, +-- retrieve AvsDataPersonCard with longest validity for a given licence, -- first argument is a lower bound for avsDataValidTo, usually current day -- Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case) -getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard -getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards - where - licence = licence2char licence' - validLicenceCards = Set.filter cardMatch cards - cardMatch AvsDataPersonCard{..} = - avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) - +-- getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard +-- getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards +-- where +-- licence = licence2char licence' +-- validLicenceCards = Set.filter cardMatch cards +-- cardMatch AvsDataPersonCard{..} = +-- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) +-- | DEPRECTATED getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) getCompanyAddress card@AvsDataPersonCard{..} | Just street <- avsDataStreet diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index de9608a4d..d4d0a0f69 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -29,6 +29,13 @@ import GHC.Stack (HasCallStack, CallStack, callStack) -- import Control.Monad.Trans.Reader (withReaderT) +-- | Obtain the record projection from the EntityField value +getFieldEnt :: PersistEntity record => EntityField record typ -> Entity record -> typ +getFieldEnt = view . fieldLens + +getField :: PersistEntity record => EntityField record typ -> record -> typ +getField = (. Entity (error "getField required key")) . getFieldEnt + emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) -- 2.39.2 From 83afdf760f93fc1a553de3a122b444412ed84ba4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 12 Jan 2024 10:31:33 +0100 Subject: [PATCH 03/85] fix(build): missing parameters added --- test/Database/Fill.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index c1c657912..743c27e96 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -595,7 +595,7 @@ fillDb = do let matrikel = tshow <$> [baseMatrikel..] List.\\ [6969, 669966, 996699] manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel matUsers <- selectList [UserMatrikelnummer !=. Nothing] [] - insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] + insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing Nothing Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] let tmin = -1 tmax = 2 @@ -723,12 +723,12 @@ fillDb = do void . insert' $ UserSchool uid mi False for_ [jost] $ \uid -> void . insert' $ UserSchool uid avn False - void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") - void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing - void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing - void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing - void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") - void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing + void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing insert_ $ UserAvsCard (AvsPersonId 12345678) (AvsFullCardNo (AvsCardNo "1234") "4") (AvsDataPersonCard True Nothing Nothing AvsCardColorGelb (Set.fromList ['F']) Nothing Nothing Nothing Nothing (AvsCardNo "1234") "4") now insert_ $ UserAvsCard (AvsPersonId 2) (AvsFullCardNo (AvsCardNo "3344") "1") (AvsDataPersonCard True Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "3344") "1") now insert_ $ UserAvsCard (AvsPersonId 3) (AvsFullCardNo (AvsCardNo "7788") "1") (AvsDataPersonCard False Nothing Nothing AvsCardColorRot (Set.fromList ['F','R']) Nothing Nothing Nothing Nothing (AvsCardNo "7788") "1") now -- 2.39.2 From b5340a18a25e7022b981971aba11bebde131dc8f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 12 Jan 2024 15:48:54 +0100 Subject: [PATCH 04/85] chore(avs): heterogeneous list working --- models/users.model | 4 +-- src/Handler/Utils/Avs.hs | 77 ++++++++++++++++++++++++---------------- src/Model/Types/Avs.hs | 5 ++- src/Utils.hs | 12 ++++--- 4 files changed, 59 insertions(+), 39 deletions(-) diff --git a/models/users.model b/models/users.model index b23fe85b2..02f5f8af9 100644 --- a/models/users.model +++ b/models/users.model @@ -14,8 +14,8 @@ User json -- Each Uni2work user has a corresponding row in this table; created upon first login. surname UserSurname -- Display user names always through 'nameWidget displayName surname' displayName UserDisplayName - displayEmail UserEmail - email UserEmail -- Case-insensitive eMail address, used for sending TODO: make this nullable + displayEmail UserEmail -- Case-insensitive eMail address, used for sending + email UserEmail -- Case-insensitive eMail address, used for identification and fallback for sending TODO: make this nullable ident UserIdent -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 9180ed5f4..44c7bd6f0 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications, ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} @@ -571,16 +571,22 @@ updateReceivers uid = do ------------------ -- CR3 Functions -updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) - => AvsPersonId -> m (Maybe UserId) -updateAvsUserById apid = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid - case Set.elems $ Set.filter ((== apid) . avsContactPersonID) adcs of - [] -> throwM AvsPersonSearchEmpty - (_:_:_) -> throwM AvsPersonSearchAmbiguous - [AvsDataContact _apid _avsPersonInfo _avsFirmInfo] -> do - return Nothing -- TODO + +-- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate ((typ -> f typ) -> iavs -> f iavs) (EntityField record typ) -- A Lens and a User Field; does not work. +data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate ((typ -> Const typ typ) -> iavs -> Const typ iavs) (EntityField record typ) -- A Lens and a User Field + +-- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value, +-- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query +mkUpdate :: PersistEntity record => record -> iavs -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) +mkUpdate usr npi opi (CheckAvsUpdate la up) + | let newval = npi ^. la + , let oldval = opi ^. la + , let usrval = getField up usr + , oldval /= newval + , oldval == usrval + = Just (up =. newval) +mkUpdate _ _ _ _ = Nothing + updateAvsUserByIds :: Set AvsPersonId -> Handler (Set UserId) updateAvsUserByIds apids = do @@ -591,23 +597,32 @@ updateAvsUserByIds apids = do procResp (AvsDataContact apid avsPersonInfo _avsFirmInfo) | apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order) | otherwise = runDB $ - getBy (UniqueUserAvsId apid) >>= continueJust ( \(Entity _ usravs) -> - let usrId = userAvsUser usravs in - get usrId >>= continueJust ( \usr -> do - let ups = mapMaybe (mkUpdate usr avsPersonInfo $ userAvsLastPersonInfo usravs) - [ (_avsInfoFirstName , UserFirstName ) - , (_avsInfoLastName , UserSurname ) - , (_avsInfoDisplayName, UserDisplayName) - -- , (_avsInfoDateOfBirth, UserBirthday ) -- not polymorphic enough, needs type annotation - ] - update usrId ups - return $ Set.singleton usrId - )) - mkUpdate usr npi (Just opi) (la, up) - | let newval = npi ^. la - , let oldval = opi ^. la - , let usrval = getField up usr - , oldval /= newval - , oldval == usrval - = Just (up =. newval) - mkUpdate _ _ _ _ = Nothing + getBy (UniqueUserAvsId apid) >>= foldMapM ( \(Entity _ usravs) -> + continueJust (userAvsLastPersonInfo usravs) ( \oldAvsPersonInfo -> + let usrId = userAvsUser usravs in + get usrId >>= foldMapM ( \usr -> do + let ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo) + [ CheckAvsUpdate _avsInfoFirstName UserFirstName + , CheckAvsUpdate _avsInfoLastName UserSurname + , CheckAvsUpdate _avsInfoDisplayName UserDisplayName + , CheckAvsUpdate _avsInfoDateOfBirth UserBirthday + , CheckAvsUpdate _avsInfoPersonMobilePhoneNo UserMobile + , CheckAvsUpdate (_avsInfoPersonNo . re _Just) UserMatrikelnummer -- Maybe im User, aber nicht im AvsInfo + , CheckAvsUpdate (_avsInfoPersonEMail . to (fromMaybe mempty) . from _CI) UserDisplayEmail -- Maybe nicht im AvsInfo, aber im AvsInfo + , CheckAvsUpdate (_avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . to Just) UserCompanyPersonalNumber -- Maybe im User und im AvsInfo + ] + update usrId ups + return $ Set.singleton usrId + ))) + + +updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) + => AvsPersonId -> m (Maybe UserId) +updateAvsUserById apid = do + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid + case Set.elems $ Set.filter ((== apid) . avsContactPersonID) adcs of + [] -> throwM AvsPersonSearchEmpty + (_:_:_) -> throwM AvsPersonSearchAmbiguous + [AvsDataContact _apid _avsPersonInfo _avsFirmInfo] -> do + return Nothing -- TODO diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index debe9c26d..18388afb4 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -94,12 +94,15 @@ mkAvsInternalPersonalNo :: Text -> AvsInternalPersonalNo mkAvsInternalPersonalNo = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo instance Canonical AvsInternalPersonalNo where - canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ Text.dropWhile (\c -> '0' == c || Char.isSpace c) ipn + canonical (AvsInternalPersonalNo ipn) = AvsInternalPersonalNo $ normalizeAvsInternalPersonalNo ipn instance FromJSON AvsInternalPersonalNo where parseJSON x = AvsInternalPersonalNo . normalizeAvsInternalPersonalNo <$> parseJSON x instance ToJSON AvsInternalPersonalNo where toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn +_avsInternalPersonalNo :: Lens' AvsInternalPersonalNo Text +_avsInternalPersonalNo = lens (normalizeAvsInternalPersonalNo . avsInternalPersonalNo) (const mkAvsInternalPersonalNo) + type instance Element AvsInternalPersonalNo = Char instance MonoFoldable AvsInternalPersonalNo where ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo diff --git a/src/Utils.hs b/src/Utils.hs index 77c6bf59a..7e83ba5c9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -900,15 +900,11 @@ filterMaybe c r@(Just x) | c x = r filterMaybe _ _ = Nothing -- | also referred to as whenJust and forM_ +-- also see `foldMapM` if a Monoid value is to be returned whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () --- | synonym for `flip foldMapM` -continueJust :: (Monoid m, Applicative f) => (a -> f m) -> Maybe a -> f m -continueJust f (Just x) = f x -continueJust _ Nothing = pure mempty - ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM ifMaybeM Nothing dft _ = return dft ifMaybeM (Just x) _ act = act x @@ -1218,6 +1214,12 @@ ofoldl1M _ _ = error "otoList of NonNull is empty" foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty +-- | convenient synonym for `flip foldMapM` +continueJust :: (Applicative m, Monoid b) => Maybe a -> (a -> m b) -> m b +continueJust (Just x) f = f x +continueJust Nothing _ = pure mempty + + ifoldMapM :: (FoldableWithIndex i f, Monad m, Monoid b) => (i -> a -> m b) -> f a -> m b ifoldMapM f = ifoldrM (\i x xs -> (<> xs) <$> f i x) mempty -- 2.39.2 From cb807fce98ec4742bc5a4e6797684d0f20f2406f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 12 Jan 2024 16:57:17 +0100 Subject: [PATCH 05/85] refactor(avs): using MaybeT --- src/Handler/Utils/Avs.hs | 41 ++++++++++++++++++++-------------------- src/Utils.hs | 8 +++++++- 2 files changed, 27 insertions(+), 22 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 44c7bd6f0..e999ea1af 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -572,13 +572,13 @@ updateReceivers uid = do -- CR3 Functions --- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate ((typ -> f typ) -> iavs -> f iavs) (EntityField record typ) -- A Lens and a User Field; does not work. -data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate ((typ -> Const typ typ) -> iavs -> Const typ iavs) (EntityField record typ) -- A Lens and a User Field +-- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate (EntityField record typ) ((typ -> f typ) -> iavs -> f iavs) -- An Record Field and fitting Lens +data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) ((typ -> Const typ typ) -> iavs -> Const typ iavs) -- An Record Field and fitting Lens -- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value, -- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query mkUpdate :: PersistEntity record => record -> iavs -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) -mkUpdate usr npi opi (CheckAvsUpdate la up) +mkUpdate usr npi opi (CheckAvsUpdate up la) | let newval = npi ^. la , let oldval = opi ^. la , let usrval = getField up usr @@ -596,24 +596,23 @@ updateAvsUserByIds apids = do where procResp (AvsDataContact apid avsPersonInfo _avsFirmInfo) | apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order) - | otherwise = runDB $ - getBy (UniqueUserAvsId apid) >>= foldMapM ( \(Entity _ usravs) -> - continueJust (userAvsLastPersonInfo usravs) ( \oldAvsPersonInfo -> - let usrId = userAvsUser usravs in - get usrId >>= foldMapM ( \usr -> do - let ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo) - [ CheckAvsUpdate _avsInfoFirstName UserFirstName - , CheckAvsUpdate _avsInfoLastName UserSurname - , CheckAvsUpdate _avsInfoDisplayName UserDisplayName - , CheckAvsUpdate _avsInfoDateOfBirth UserBirthday - , CheckAvsUpdate _avsInfoPersonMobilePhoneNo UserMobile - , CheckAvsUpdate (_avsInfoPersonNo . re _Just) UserMatrikelnummer -- Maybe im User, aber nicht im AvsInfo - , CheckAvsUpdate (_avsInfoPersonEMail . to (fromMaybe mempty) . from _CI) UserDisplayEmail -- Maybe nicht im AvsInfo, aber im AvsInfo - , CheckAvsUpdate (_avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . to Just) UserCompanyPersonalNumber -- Maybe im User und im AvsInfo - ] - update usrId ups - return $ Set.singleton usrId - ))) + | otherwise = fmap maybeMonoid . runDB . runMaybeT $ do + (Entity _ usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid + oldAvsPersonInfo <- hoistMaybe $ userAvsLastPersonInfo usravs + let usrId = userAvsUser usravs + usr <- MaybeT $ get usrId + let ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo) + [ CheckAvsUpdate UserFirstName _avsInfoFirstName + , CheckAvsUpdate UserSurname _avsInfoLastName + , CheckAvsUpdate UserDisplayName _avsInfoDisplayName + , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth + , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo + , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` + , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo + , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo + ] + lift $ update usrId ups + return $ Set.singleton usrId updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) diff --git a/src/Utils.hs b/src/Utils.hs index 7e83ba5c9..21cda5764 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1214,11 +1214,17 @@ ofoldl1M _ _ = error "otoList of NonNull is empty" foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty --- | convenient synonym for `flip foldMapM` +{- left as a remineder: if you need these, use MaybeT instead! +-- convenient synonym for `flip foldMapM` continueJust :: (Applicative m, Monoid b) => Maybe a -> (a -> m b) -> m b continueJust (Just x) f = f x continueJust Nothing _ = pure mempty +maybeContinue :: (Monoid b, Monad m) => m (Maybe a) -> (a -> m b) -> m b +maybeContinue mx f = mx >>= \case + Nothing -> return mempty + Just x -> f x +-} ifoldMapM :: (FoldableWithIndex i f, Monad m, Monoid b) => (i -> a -> m b) -> f a -> m b ifoldMapM f = ifoldrM (\i x xs -> (<> xs) <$> f i x) mempty -- 2.39.2 From 45c3f11a831a811ebfd2558669922ca08412c5bc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 12 Jan 2024 18:13:23 +0100 Subject: [PATCH 06/85] chore(avs): add failure notices after contact update --- src/Handler/Utils/Avs.hs | 62 ++++++++++++++++-------------- src/Jobs/Handler/SynchroniseAvs.hs | 5 +-- 2 files changed, 36 insertions(+), 31 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index e999ea1af..644f47af6 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -588,40 +588,46 @@ mkUpdate usr npi opi (CheckAvsUpdate up la) mkUpdate _ _ _ _ = Nothing -updateAvsUserByIds :: Set AvsPersonId -> Handler (Set UserId) +updateAvsUserByIds :: Set AvsPersonId -> Handler (Set (AvsPersonId, UserId)) updateAvsUserByIds apids = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids - foldMapM procResp adcs + res <- foldMapM procResp adcs + let missing = Set.toList $ Set.difference apids $ Set.map fst res + unless (null missing) $ runDB $ do + now <- liftIO getCurrentTime + updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] + return res where - procResp (AvsDataContact apid avsPersonInfo _avsFirmInfo) + procResp (AvsDataContact apid avsPersonInfo avsFirmInfo) | apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order) | otherwise = fmap maybeMonoid . runDB . runMaybeT $ do - (Entity _ usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid - oldAvsPersonInfo <- hoistMaybe $ userAvsLastPersonInfo usravs + (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid + oldAvsPersonInfo <- hoistMaybe $ userAvsLastPersonInfo usravs -- TODO this hoist maybe should not abort the entire synch!!! + -- oldAvsFirmInfo <- hoistMaybe $ userAvsLastFirmInfo usravs -- TODO this hoist maybe should not abort the entire synch!!! let usrId = userAvsUser usravs usr <- MaybeT $ get usrId - let ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo) - [ CheckAvsUpdate UserFirstName _avsInfoFirstName - , CheckAvsUpdate UserSurname _avsInfoLastName - , CheckAvsUpdate UserDisplayName _avsInfoDisplayName - , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth - , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo - , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo - , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo - ] - lift $ update usrId ups - return $ Set.singleton usrId + now <- liftIO getCurrentTime + let usr_ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo) + [ CheckAvsUpdate UserFirstName _avsInfoFirstName + , CheckAvsUpdate UserSurname _avsInfoLastName + , CheckAvsUpdate UserDisplayName _avsInfoDisplayName + , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth + , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo + , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` + , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo + , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo + ] + -- frm_ups = mapMaybe (mkUpdate usr avsFirmInfo oldAvsFirmInfo) + -- [ CheckAvsUpdate - -updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) - => AvsPersonId -> m (Maybe UserId) -updateAvsUserById apid = do - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid - case Set.elems $ Set.filter ((== apid) . avsContactPersonID) adcs of - [] -> throwM AvsPersonSearchEmpty - (_:_:_) -> throwM AvsPersonSearchAmbiguous - [AvsDataContact _apid _avsPersonInfo _avsFirmInfo] -> do - return Nothing -- TODO + -- ] + avs_ups = [ UserAvsNoPerson =. api | Just api <- [readMay $ avsInfoPersonNo avsPersonInfo]] + <> [ UserAvsLastSynch =. now + , UserAvsLastSynchError =. Nothing + , UserAvsLastPersonInfo =. Just avsPersonInfo + , UserAvsLastFirmInfo =. Just avsFirmInfo + ] + lift $ update usrId usr_ups + lift $ update uaId avs_ups + return $ Set.singleton (apid, usrId) diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 0b393f0e2..6829386aa 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -93,9 +93,8 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do void $ queueJob JobSynchroniseAvsNext catch (void $ upsertAvsUserById apid) -- already updates UserAvsLastSynch (\exc -> do - now <- liftIO getCurrentTime - let excMsg = tshow exc <> " at " <> tshow now - runDB (update avsKey [UserAvsLastSynchError =. Just excMsg, UserAvsLastSynch =. now]) + now <- liftIO getCurrentTime + runDB (update avsKey [UserAvsLastSynchError =. Just (tshow exc), UserAvsLastSynch =. now]) case exc of AvsInterfaceUnavailable -> return () -- ignore and retry later AvsUserUnknownByAvs _ -> return () -- ignore for users no longer listed in AVS -- 2.39.2 From e8d66a47349923df5b01a868edb64568ca89433c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 17 Jan 2024 16:14:21 +0100 Subject: [PATCH 07/85] chore(avs): lenses for virtual avs fields created --- models/avs.model | 2 +- models/company.model | 4 +-- models/users.model | 4 +-- src/Handler/Course/User.hs | 2 +- src/Handler/Utils/Avs.hs | 25 ++++++++------- src/Handler/Utils/Mail.hs | 10 +++--- src/Handler/Utils/Pandoc.hs | 28 ++++------------- src/Handler/Utils/Profile.hs | 41 ++++--------------------- src/Handler/Utils/Users.hs | 2 +- src/Jobs/Handler/QueueNotification.hs | 4 +-- src/Model/Types/Avs.hs | 43 +++++++++++++++++++++++++- src/Model/Types/Markup.hs | 5 +-- src/Utils.hs | 11 ++++++- src/Utils/Mail.hs | 44 +++++++++++++++++++++++++++ src/Utils/Pandoc.hs | 43 ++++++++++++++++++++++++++ templates/course/user/profile.hamlet | 4 +-- 16 files changed, 184 insertions(+), 88 deletions(-) create mode 100644 src/Utils/Mail.hs create mode 100644 src/Utils/Pandoc.hs diff --git a/models/avs.model b/models/avs.model index 5147f382e..30e5e8ea8 100644 --- a/models/avs.model +++ b/models/avs.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/models/company.model b/models/company.model index c022ad5f1..811af197d 100644 --- a/models/company.model +++ b/models/company.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,7 +9,7 @@ Company shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future avsId Int default=0 -- primary key from avs prefersPostal Bool default=false -- new company users prefers letters by post instead of email - postAddress StoredMarkup Maybe -- default company postal address + postAddress StoredMarkup Maybe -- default company postal address, including company name email UserEmail Maybe -- Case-insensitive generic company eMail address UniqueCompanyName name UniqueCompanyShorthand shorthand diff --git a/models/users.model b/models/users.model index 02f5f8af9..7ee24e9fb 100644 --- a/models/users.model +++ b/models/users.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -45,7 +45,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create companyPersonalNumber Text Maybe -- Company will become a new table, but if company=fraport, some information is received via LDAP companyDepartment Text Maybe -- thus we store such information for ease of reference directly, if available pinPassword Text Maybe -- used to encrypt pins within emails - postAddress StoredMarkup Maybe + postAddress StoredMarkup Maybe -- including company name, if any postLastUpdate UTCTime Maybe -- record postal address updates prefersPostal Bool default=false -- user prefers letters by post instead of email examOfficeGetSynced Bool default=true -- whether synced status should be displayed for exam results by default diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index b7e54719c..b24dfd744 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -11,7 +11,7 @@ import Import import Utils.Form import Handler.Utils import Handler.Utils.SheetType -import Handler.Utils.Profile (pickValidEmail) +import Handler.Utils.Profile (pickValidUserEmail) import Handler.Utils.StudyFeatures import Handler.Submission.List diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 644f47af6..2d7084829 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -603,31 +603,34 @@ updateAvsUserByIds apids = do | apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order) | otherwise = fmap maybeMonoid . runDB . runMaybeT $ do (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid - oldAvsPersonInfo <- hoistMaybe $ userAvsLastPersonInfo usravs -- TODO this hoist maybe should not abort the entire synch!!! - -- oldAvsFirmInfo <- hoistMaybe $ userAvsLastFirmInfo usravs -- TODO this hoist maybe should not abort the entire synch!!! + let oldAvsPersonInfo = userAvsLastPersonInfo usravs -- Nothing here must not abort the entire synch, hence no hoistMaybe here + let oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing here must not abort the entire synch, hence no hoistMaybe here let usrId = userAvsUser usravs usr <- MaybeT $ get usrId now <- liftIO getCurrentTime - let usr_ups = mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo) + let usr_ups = maybeEmpty oldAvsPersonInfo $ \oldAvsPersonInfo' -> mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo') [ CheckAvsUpdate UserFirstName _avsInfoFirstName , CheckAvsUpdate UserSurname _avsInfoLastName , CheckAvsUpdate UserDisplayName _avsInfoDisplayName , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo + -- , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo ] - -- frm_ups = mapMaybe (mkUpdate usr avsFirmInfo oldAvsFirmInfo) - -- [ CheckAvsUpdate + frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr avsFirmInfo oldAvsFirmInfo') + [ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup) - -- ] - avs_ups = [ UserAvsNoPerson =. api | Just api <- [readMay $ avsInfoPersonNo avsPersonInfo]] + ] + -- TODO: update Email + -- _avsFirmPrimaryEmail <|> _avsInfoPersonEMail + -- TODO: update Company + avs_ups = maybeToList ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo avsPersonInfo)) <> [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing , UserAvsLastPersonInfo =. Just avsPersonInfo , UserAvsLastFirmInfo =. Just avsFirmInfo ] - lift $ update usrId usr_ups - lift $ update uaId avs_ups + lift $ update usrId $ usr_ups <> frm_ups + lift $ update uaId avs_ups return $ Set.singleton (apid, usrId) diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 851928033..7511a9673 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -37,7 +37,7 @@ addRecipientsDB :: ( MonadMail m addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient where addRecipient (Entity _ User{userEmail, userDisplayEmail, userDisplayName}) = do - let addr = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + let addr = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail _mailTo %= flip snoc addr userAddressFrom :: User -> Address @@ -51,16 +51,16 @@ userAddress :: User -> Address -- -- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy. userAddress User{userEmail, userDisplayEmail, userDisplayName} - = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address -- Like userAddress', but does not require a complete entity userAddress' userEmail userDisplayEmail userDisplayName - = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + = Address (Just userDisplayName) $ CI.original $ pickValidUserEmail userDisplayEmail userEmail userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address) userAddressError User{userEmail, userDisplayEmail, userDisplayName} - | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) + | Just okEmail <- pickValidUserEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) | otherwise = do $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " / " <> tshow userEmail <> ". Sent to support instead." -- <> " with subject " <> tshow failedSubject (False,) <$> getsYesod (view _appMailSupport) @@ -74,7 +74,7 @@ userMailT :: ( MonadHandler m userMailT uid mAct = do (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid let undername = underling ^. _userDisplayName -- nameHtml' underling - undermail = CI.original $ pickValidEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail) + undermail = CI.original $ pickValidUserEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail) infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|

_{MsgMailSupervisedNote}

diff --git a/src/Handler/Utils/Pandoc.hs b/src/Handler/Utils/Pandoc.hs index 797bcf625..c138f0a76 100644 --- a/src/Handler/Utils/Pandoc.hs +++ b/src/Handler/Utils/Pandoc.hs @@ -1,17 +1,18 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Utils.Pandoc - ( htmlField, htmlFieldSmall - , renderMarkdownWith, parseMarkdownWith - , htmlReaderOptions, markdownReaderOptions - , markdownWriterOptions, htmlWriterOptions + ( module Utils.Pandoc + , htmlField, htmlFieldSmall + , renderMarkdownWith, parseMarkdownWith ) where import Import.NoFoundation +import Utils.Pandoc import Handler.Utils.I18n + import qualified Data.Text as Text import qualified Data.Text.Lazy as LT @@ -86,20 +87,3 @@ plaintextToMarkdownWith writerOptions text = where logPandocError = $logErrorS "renderMarkdown" . tshow pandoc = P.Pandoc mempty [P.Plain [P.Str text]] - - -htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions -htmlReaderOptions = markdownReaderOptions -markdownReaderOptions = def - { P.readerExtensions = P.pandocExtensions - & P.enableExtension P.Ext_hard_line_breaks - & P.enableExtension P.Ext_autolink_bare_uris - , P.readerTabStop = 2 - } - -markdownWriterOptions, htmlWriterOptions :: P.WriterOptions -markdownWriterOptions = def - { P.writerExtensions = P.readerExtensions markdownReaderOptions - , P.writerTabStop = P.readerTabStop markdownReaderOptions - } -htmlWriterOptions = markdownWriterOptions diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 4f8e87546..ee321a491 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -1,13 +1,13 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later -- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? -- TODO: consider merging with Handler.Utils.Users? module Handler.Utils.Profile - ( validDisplayName, checkDisplayName, fixDisplayName - , validPostAddress - , validEmail, validEmail', pickValidEmail, pickValidEmail' + ( module Utils.Mail + , validDisplayName, checkDisplayName, fixDisplayName + , validPostAddress , validFraportPersonalNumber ) where @@ -16,16 +16,12 @@ import Import.NoFoundation import Data.Char import qualified Data.Text as Text import qualified Data.Text.Lazy as LT -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import qualified Data.MultiSet as MultiSet import qualified Data.Set as Set -import qualified Text.Email.Validate as Email - --- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc. -stripFold :: Text -> Text -stripFold = Text.toCaseFold . Text.strip +import Utils.Mail -- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname". -- Input "givennames surname" is left unchanged, except for removing excess whitespace @@ -78,31 +74,6 @@ validPostAddress (Just StoredMarkup {markupInput = addr}) = True validPostAddress _ = False --- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type -validEmail :: Email -> Bool -- Email = Text -validEmail email = validRFC5322 && not invalidFraport - where - validRFC5322 = Email.isValid $ encodeUtf8 email - invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of - Just fralogin -> all isDigit $ drop 1 fralogin - Nothing -> False - -validEmail' :: UserEmail -> Bool -- UserEmail = CI Text -validEmail' = validEmail . CI.original - --- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function -pickValidEmail :: UserEmail -> UserEmail -> UserEmail -pickValidEmail x y - | validEmail' x = x - | otherwise = y - --- | returns first valid email address or none if none are valid -pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail -pickValidEmail' x y - | validEmail' x = Just x - | validEmail' y = Just y - | otherwise = Nothing - validFraportPersonalNumber :: Maybe Text -> Bool validFraportPersonalNumber Nothing = False validFraportPersonalNumber (Just t) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 5c85c9c73..223f58f28 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -86,7 +86,7 @@ getPostalPreferenceAndAddress usr@User{userPrefersPostal} = emailPossible = isJust $ getEmailAddress usr getEmailAddress :: User -> Maybe UserEmail -getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail +getEmailAddress User{userDisplayEmail, userEmail} = pickValidUserEmail' userDisplayEmail userEmail getPostalAddress :: User -> Maybe [Text] getPostalAddress User{..} diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index a4a407afa..6d1d5a317 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -16,7 +16,7 @@ import Jobs.Queue import qualified Data.Set as Set -import Handler.Utils.Profile (pickValidEmail') +import Handler.Utils.Profile (pickValidUserEmail') import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.ExternalExam @@ -28,7 +28,7 @@ dispatchJobQueueNotification jNotification = JobHandlerAtomic $ runConduit $ yield jNotification .| transPipe (hoist lift) determineNotificationCandidates .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) -> - and2M (return $ isJust $ pickValidEmail' userDisplayEmail userEmail) $ + and2M (return $ isJust $ pickValidUserEmail' userDisplayEmail userEmail) $ or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification')) .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification') .| sinkDBJobs diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 18388afb4..63fb8cf53 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -27,6 +27,7 @@ import qualified Data.Set as Set import Data.Aeson import Data.Aeson.Types +import Utils.Mail {- -- | Like (.:) but attempts parsing with case-insensitve keys as fallback. @@ -77,6 +78,22 @@ instance FromJSON SloppyBool where parseJSON invalid = prependFailure "parsing SloppyBool failed, " $ fail $ "expected Bool or String encoding boolean. Found " ++ show invalid +------------------------ +-- Specific Utilities -- +------------------------ + +composeAddress :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text +composeAddress street zipcode city country = toMaybe (notNull compAddr) compAddr + where + compAddr = textUnlines $ stripList [street, zipCity, country'] + zipCity = Just $ Text.unwords $ stripList [zipcode, city] + country' = case country of + (Just "Deutschland") -> Nothing -- letters sent by APC originate in Germany + other -> other + + stripList xs = [y | Just x <- xs, let y = Text.strip x, notNull y] + + ------------------- -- AVS Datatypes -- ------------------- @@ -552,6 +569,10 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where canonical other = other makeLenses_ ''AvsFirmCommunication +_avsCommunicationAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmCommunication (Maybe Text) +_avsCommunicationAddress = to mkAddr + where + mkAddr AvsFirmCommunication{..} = composeAddress avsCommunicationStreetANDHouseNo avsCommunicationZIPCode avsCommunicationCity avsCommunicationCountry instance FromJSON AvsFirmCommunication where parseJSON = withObject "AvsFirmCommunication" $ \o -> AvsFirmCommunication @@ -586,6 +607,26 @@ data AvsFirmInfo = AvsFirmInfo makeLenses_ ''AvsFirmInfo +-- | FirmAddress is never empty, since it always includes the company name +_avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text +_avsFirmAddress = to mkAddr + where + mkAddr AvsFirmInfo{..} = + let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry + commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress + in textUnlines $ avsFirmFirm : catMaybes [commAddr <|> firmAddr] + +_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +_avsFirmPrimaryEmail = to mkEmail + where + mkEmail afi = + let candidates = catMaybes + [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail + , afi ^. _avsFirmEMailSuperior + , afi ^. _avsFirmEMail + ] + in pickValidEmail candidates -- should we return an invalid email rather than none? + instance FromJSON AvsFirmInfo where parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo <$> o .: "Firm" diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index 0715b65b5..b2a22915d 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -32,6 +32,7 @@ import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Persist.Sql +import Utils.Pandoc data MarkupFormat = MarkupMarkdown @@ -67,7 +68,7 @@ plaintextToStoredMarkup :: Textual t => t -> StoredMarkup plaintextToStoredMarkup (repack -> t) = StoredMarkup { markupInputFormat = MarkupPlaintext , markupInput = t - , markupOutput = toMarkup t + , markupOutput = plaintextToHtml $ LT.toStrict t } preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup preEscapedToStoredMarkup (repack -> t) = StoredMarkup @@ -79,7 +80,7 @@ markdownToStoredMarkup :: Textual t => t -> StoredMarkup markdownToStoredMarkup (repack -> t) = StoredMarkup { markupInputFormat = MarkupMarkdown , markupInput = t - , markupOutput = toMarkup t -- not sure here + , markupOutput = plaintextToHtml $ LT.toStrict t } diff --git a/src/Utils.hs b/src/Utils.hs index 21cda5764..5ae894f30 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -305,6 +305,11 @@ tshowCrop = cropText . tshow stripCI :: Text -> CI Text stripCI = CI.mk . Text.strip +-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc. +stripFold :: Text -> Text +stripFold = Text.toCaseFold . Text.strip + + -- | just to avoid adding an import for this ciOriginal :: CI Text -> Text ciOriginal = CI.original @@ -513,6 +518,10 @@ snakecase2camelcase t = Text.concat $ map textToCapital words words = Text.splitOn '_' t -} +-- | Unlike @Data.Text.unlines, there is no trailing LF at the end +textUnlines :: [Text] -> Text +textUnlines = Text.intercalate $ Text.singleton '\n' + -- also see Utils.Form.cfCommaSeparatedSet commaSeparatedText :: Text -> Set Text commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',') diff --git a/src/Utils/Mail.hs b/src/Utils/Mail.hs new file mode 100644 index 000000000..954ef207f --- /dev/null +++ b/src/Utils/Mail.hs @@ -0,0 +1,44 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Utils.Mail where + + +import Import.NoModel + +import qualified Data.Char as Char +import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI + +import qualified Text.Email.Validate as Email + +-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type +validEmail :: Text -> Bool -- Email = Text +validEmail email = validRFC5322 && not invalidFraport + where + validRFC5322 = Email.isValid $ encodeUtf8 email + invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of + Just fralogin -> Text.all Char.isDigit $ Text.drop 1 fralogin + Nothing -> False + +validEmail' :: CI Text -> Bool -- UserEmail = CI Text +validEmail' = validEmail . CI.original + +-- | returns the first valid Email, if any +pickValidEmail :: [Text] -> Maybe Text +pickValidEmail = find validEmail + + +-- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function +pickValidUserEmail :: CI Text -> CI Text -> CI Text +pickValidUserEmail x y + | validEmail' x = x + | otherwise = y + +-- | returns first valid email address or none if none are valid +pickValidUserEmail' :: CI Text -> CI Text -> Maybe (CI Text) +pickValidUserEmail' x y + | validEmail' x = Just x + | validEmail' y = Just y + | otherwise = Nothing \ No newline at end of file diff --git a/src/Utils/Pandoc.hs b/src/Utils/Pandoc.hs new file mode 100644 index 000000000..ad7582377 --- /dev/null +++ b/src/Utils/Pandoc.hs @@ -0,0 +1,43 @@ +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Utils.Pandoc where + + +import Import.NoModel + +import Data.Either (fromRight) +-- import qualified Data.Char as Char +-- import qualified Data.Text as Text +-- import qualified Data.CaseInsensitive as CI +import Text.Blaze (toMarkup) +import Text.Blaze.Html.Renderer.Text (renderHtml) +import qualified Text.Pandoc as P + + +markdownToHtml :: Html -> Either P.PandocError Html +markdownToHtml html = P.runPure $ P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions (toStrict $ renderHtml html) + +plaintextToHtml :: Text -> Html +plaintextToHtml text = fromRight (toMarkup text) $ P.runPure $ + P.writeHtml5 htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text + -- Line below does not work as intended, also see Handler.Utils.Pandoc.plaintextToMarkdownWith which uses this code + -- where pandoc = P.Pandoc mempty [P.Plain [P.Str text]] + + +htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions +htmlReaderOptions = markdownReaderOptions +markdownReaderOptions = def + { P.readerExtensions = P.pandocExtensions + & P.enableExtension P.Ext_hard_line_breaks + & P.enableExtension P.Ext_autolink_bare_uris + , P.readerTabStop = 2 + } + +markdownWriterOptions, htmlWriterOptions :: P.WriterOptions +markdownWriterOptions = def + { P.writerExtensions = P.readerExtensions markdownReaderOptions + , P.writerTabStop = P.readerTabStop markdownReaderOptions + } +htmlWriterOptions = markdownWriterOptions \ No newline at end of file diff --git a/templates/course/user/profile.hamlet b/templates/course/user/profile.hamlet index b43e61c70..c18be7f33 100644 --- a/templates/course/user/profile.hamlet +++ b/templates/course/user/profile.hamlet @@ -1,6 +1,6 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +$# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Winnie Ros ,Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later @@ -24,7 +24,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

_{MsgTableSex}
_{sex}
_{MsgTableEmail} -
#{mailtoHtml (pickValidEmail userDisplayEmail userEmail)} +
#{mailtoHtml (pickValidUserEmail userDisplayEmail userEmail)} $maybe date <- mRegAt
_{MsgRegisteredSince}
#{date} -- 2.39.2 From 9bf38d8198303762b73d152fd9f22f9e58d280a2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 18 Jan 2024 17:19:44 +0100 Subject: [PATCH 08/85] chore(avs): email updating implemented --- src/Handler/Utils/Avs.hs | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 2d7084829..72e232b1d 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -578,9 +578,9 @@ data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => Chec -- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value, -- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query mkUpdate :: PersistEntity record => record -> iavs -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) -mkUpdate usr npi opi (CheckAvsUpdate up la) - | let newval = npi ^. la - , let oldval = opi ^. la +mkUpdate usr newapi oldapi (CheckAvsUpdate up la) + | let newval = newapi ^. la + , let oldval = oldapi ^. la , let usrval = getField up usr , oldval /= newval , oldval == usrval @@ -599,7 +599,7 @@ updateAvsUserByIds apids = do updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] return res where - procResp (AvsDataContact apid avsPersonInfo avsFirmInfo) + procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) | apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order) | otherwise = fmap maybeMonoid . runDB . runMaybeT $ do (Entity uaId usravs) <- MaybeT $ getBy $ UniqueUserAvsId apid @@ -608,29 +608,31 @@ updateAvsUserByIds apids = do let usrId = userAvsUser usravs usr <- MaybeT $ get usrId now <- liftIO getCurrentTime - let usr_ups = maybeEmpty oldAvsPersonInfo $ \oldAvsPersonInfo' -> mapMaybe (mkUpdate usr avsPersonInfo oldAvsPersonInfo') + let per_ups = maybeEmpty oldAvsPersonInfo $ \oldAvsPersonInfo' -> mapMaybe (mkUpdate usr newAvsPersonInfo oldAvsPersonInfo') [ CheckAvsUpdate UserFirstName _avsInfoFirstName , CheckAvsUpdate UserSurname _avsInfoLastName , CheckAvsUpdate UserDisplayName _avsInfoDisplayName , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - -- , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo + -- , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo PROBLEM: Hängt auch von der FirmenEmail ab und muss daher im Verbund betrachtet werden. , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo ] - frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr avsFirmInfo oldAvsFirmInfo') + frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr newAvsFirmInfo oldAvsFirmInfo') [ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup) - ] - -- TODO: update Email - -- _avsFirmPrimaryEmail <|> _avsInfoPersonEMail + eml_up = let -- Comm > Superior > Company > Personal; NOTE: Email update depends on both AvsFirmInfo and AvsPersonInfo simultaneously + eml_old = (oldAvsFirmInfo ^. _Just . _avsFirmPrimaryEmail) <|> (oldAvsPersonInfo ^. _Just . _avsInfoPersonEMail) + eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail) + in mkUpdate usr eml_new eml_old $ CheckAvsUpdate UserDisplayEmail $ to (fromMaybe mempty) . from _CI + usr_ups = mcons eml_up $ frm_ups <> per_ups -- TODO: update Company - avs_ups = maybeToList ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo avsPersonInfo)) - <> [ UserAvsLastSynch =. now + avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` + [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing - , UserAvsLastPersonInfo =. Just avsPersonInfo - , UserAvsLastFirmInfo =. Just avsFirmInfo + , UserAvsLastPersonInfo =. Just newAvsPersonInfo + , UserAvsLastFirmInfo =. Just newAvsFirmInfo ] - lift $ update usrId $ usr_ups <> frm_ups - lift $ update uaId avs_ups + lift $ update usrId usr_ups + lift $ update uaId avs_ups return $ Set.singleton (apid, usrId) -- 2.39.2 From f40448cd316693d3defa598d25ab5efc2cd4ce2c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 19 Jan 2024 16:59:42 +0100 Subject: [PATCH 09/85] refactor(avs): minor code cleaning --- src/Handler/Utils/Avs.hs | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 72e232b1d..90c3a3c0f 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -571,7 +571,7 @@ updateReceivers uid = do ------------------ -- CR3 Functions - +-- A datatype for a specific heterogeneous list -- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate (EntityField record typ) ((typ -> f typ) -> iavs -> f iavs) -- An Record Field and fitting Lens data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) ((typ -> Const typ typ) -> iavs -> Const typ iavs) -- An Record Field and fitting Lens @@ -614,19 +614,25 @@ updateAvsUserByIds apids = do , CheckAvsUpdate UserDisplayName _avsInfoDisplayName , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo - , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - -- , CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo PROBLEM: Hängt auch von der FirmenEmail ab und muss daher im Verbund betrachtet werden. + , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo ] + eml_up = let -- Comm > Superior > Company > Personal; NOTE: Email update depends simultaneosuly on AvsFirmInfo and AvsPersonInfo + eml_old = (oldAvsFirmInfo ^. _Just . _avsFirmPrimaryEmail) <|> (oldAvsPersonInfo ^. _Just . _avsInfoPersonEMail) + eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail) + in mkUpdate usr eml_new eml_old $ + CheckAvsUpdate UserDisplayEmail $ to (fromMaybe mempty) . from _CI -- Maybe nicht im User, aber im AvsInfo PROBLEM: Hängt auch von der FirmenEmail ab und muss daher im Verbund betrachtet werden. frm_ups = maybeEmpty oldAvsFirmInfo $ \oldAvsFirmInfo' -> mapMaybe (mkUpdate usr newAvsFirmInfo oldAvsFirmInfo') [ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup) ] - eml_up = let -- Comm > Superior > Company > Personal; NOTE: Email update depends on both AvsFirmInfo and AvsPersonInfo simultaneously - eml_old = (oldAvsFirmInfo ^. _Just . _avsFirmPrimaryEmail) <|> (oldAvsPersonInfo ^. _Just . _avsInfoPersonEMail) - eml_new = (newAvsFirmInfo ^. _avsFirmPrimaryEmail) <|> (newAvsPersonInfo ^. _avsInfoPersonEMail) - in mkUpdate usr eml_new eml_old $ CheckAvsUpdate UserDisplayEmail $ to (fromMaybe mempty) . from _CI usr_ups = mcons eml_up $ frm_ups <> per_ups - -- TODO: update Company + -- TODO: update Company + -- cmp_up = let + -- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo) + -- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo) + -- cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm ) + -- cmp_new = (oldAvsFirmInfo ^. _avsFirmFirm ) + avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now , UserAvsLastSynchError =. Nothing -- 2.39.2 From de45731a9bfcaa18cce7a5a540ac38f28881e0fc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 22 Jan 2024 18:54:33 +0100 Subject: [PATCH 10/85] refactor(company): supervison and company tables changed - company avs id must be unique now, companies with id 0 are deleted - user supervision can be annotated with company and or a reason, used to avoid accidental supervision relations; company supervision resets ignore non-company supervisions --- .../uniworx/categories/user/de-de-formal.msg | 1 + messages/uniworx/categories/user/en-eu.msg | 3 +- .../utils/table_column/de-de-formal.msg | 2 + messages/uniworx/utils/table_column/en-eu.msg | 2 + models/company.model | 8 +- models/users.model | 8 +- src/Handler/Firm.hs | 44 ++++++-- src/Handler/LMS/Fake.hs | 8 +- src/Handler/Profile.hs | 106 +++++++++++++++++- src/Handler/Users.hs | 8 +- src/Handler/Utils/Avs.hs | 5 +- src/Handler/Utils/Company.hs | 4 +- src/Handler/Utils/Users.hs | 18 ++- src/Model/Migration/Definitions.hs | 20 +++- src/Model/Types/Avs.hs | 8 +- src/Utils/Lens.hs | 2 + templates/profileData.hamlet | 12 +- test/Database/Fill.hs | 28 ++--- 18 files changed, 231 insertions(+), 56 deletions(-) diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index a3c630c46..573892220 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -102,3 +102,4 @@ Name !ident-ok: Name UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt. UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden! UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht. +SupervisorReason: Begründung \ No newline at end of file diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 10c42830d..43bc1bf85 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -101,4 +101,5 @@ AuthKindNoLogin: No login Name: Name UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set. UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified! -UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. \ No newline at end of file +UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}. +SupervisorReason: Reason \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 0a67481af..43031fd5b 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableCompanyNrRerouteDefault: Standard Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen +TableRerouteActive: Umleitung TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableSupervisor: Ansprechpartner +TableSupervisee: Ansprechpartner für TableCreationTime: Erstellungszeit TableJob !ident-ok: Job TableJobContent !ident-ok: Parameter diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index e7ae23a14..8546022d9 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -91,8 +91,10 @@ TableCompanyNrSupersDefault: Default supervisors TableCompanyNrForeignSupers: External Supervisors TableCompanyNrRerouteDefault: Default reroutes TableCompanyNrRerouteActive: Active reroutes +TableRerouteActive: Reroute TableCompanyPostalPreference: Default notification preference TableSupervisor: Supervisor +TableSupervisee: Supervisor for TableCreationTime: Creation TableJob !ident-ok: Job TableJobContent !ident-ok: Parameters diff --git a/models/company.model b/models/company.model index 811af197d..422a7a14d 100644 --- a/models/company.model +++ b/models/company.model @@ -6,15 +6,15 @@ Company name CompanyName -- == (CI Text) - shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future + 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 prefersPostal Bool default=false -- new company users prefers letters by post instead of email postAddress StoredMarkup Maybe -- default company postal address, including company name email UserEmail Maybe -- Case-insensitive generic company eMail address UniqueCompanyName name - UniqueCompanyShorthand shorthand - -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id - Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } + -- UniqueCompanyShorthand shorthand -- unnecessary, since it is the primary key already + UniqueCompanyAvsId avsId + Primary shorthand -- newtype Key Company = CompanyKey { unCompanyKey :: CompanyShorthand } deriving Ord Eq Show Generic Binary -- TODO: a way to populate this table (manually) diff --git a/models/users.model b/models/users.model index 7ee24e9fb..ad7b20c00 100644 --- a/models/users.model +++ b/models/users.model @@ -94,9 +94,11 @@ UserCompany UniqueUserCompany user company -- a user may belong to multiple companies, but to each one only once deriving Generic UserSupervisor - supervisor UserId -- multiple supervisor per trainee possible + supervisor UserId -- multiple supervisor per trainee possible user UserId - rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well - UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once) + rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well + company CompanyId Maybe -- this supervisor was company default supervisor at time of entry + reason Text Maybe -- miscellanoues reason, e.g. Winterservice supervisision + UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once) deriving Generic diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5067c38ed..0d68a958f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -174,7 +174,7 @@ firmActionHandler route isAdmin = flip formResult faHandler , (CompanyPrefersPostal =.) <$> firmActCCFPostalPref ] in unless (null changes) $ do - runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes + runDB $ update cid changes addMessageI Success MsgFirmActChangeContactFirmResult reloadKeepGetParams route @@ -229,14 +229,16 @@ runFirmActionFormPost cid route isAdmin acts = do --- remove supervisors: -deleteSupervisors :: NonEmpty UserId -> DB Int64 -deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs] +-- | remove supervisors for given users; maybe restricted to those linked to a given companies +deleteSupervisors :: NonEmpty UserId -> [CompanyId] -> DB Int64 +deleteSupervisors usrs cids = deleteWhereCount $ (UserSupervisorUser <-. toList usrs) : restrictByCompany + where + restrictByCompany = guardMonoid (notNull cids) [UserSupervisorCompany <-. (Just <$> cids)] --- reset supervisors given employees of a company to default company supervision, deleting all other supervisors +-- reset supervisors given employees of a company to default company supervision, deleting all previous company-related supervisors resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 resetSupervisors cid employees = do - nr_del <- deleteSupervisors employees + nr_del <- deleteSupervisors employees [cid] nr_add <- addDefaultSupervisors cid employees return $ max nr_del nr_add @@ -252,8 +254,14 @@ addDefaultSupervisors cid employees = do E.<# (spr E.^. UserCompanyUser) E.<&> usr E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.justVal cid + E.<&> E.nothing ) - (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) + (\_old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. E.justVal cid + -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reason + ]) -- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64 @@ -276,8 +284,14 @@ addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.just (spr E.^. UserCompanyCompany) + E.<&> E.nothing ) - (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + (\_old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon + ] ) -- like `addDefaultSupervisors`, but selects all employees of given companies from database addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 @@ -295,8 +309,14 @@ addDefaultSupervisorsAll mutualSupervision cids = do E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) E.<&> (spr E.^. UserCompanySupervisorReroute) + E.<&> E.just (spr E.^. UserCompanyCompany) + E.<&> E.nothing ) - (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + (\_old new -> + [ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications + , UserSupervisorCompany E.=. new E.^. UserSupervisorCompany + -- , UserSupervisorReason E.=. new E.^. UserSupervisorReason -- keep any existing reaon + ] ) ------------------------------ @@ -1006,7 +1026,7 @@ postFirmUsersR fsh = do (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause runDB $ do delSupers <- if firmUserActResetKeepOldSupers == Just False - then deleteSupervisors uids + then deleteSupervisors uids [] else return 0 newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers @@ -1027,8 +1047,8 @@ postFirmUsersR fsh = do |] in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) delSupers <- runDB - $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep - <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers] + $ bool (deleteSupervisors uids [cid]) (return 0) firmUserActSetSuperKeep + <* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) Nothing | u <- toList uids, s <- newSupers] addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index cd7392760..d1b876db6 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -71,11 +71,11 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1] let addSupervisor = case theSupervisor of [s] -> \suid k -> case k of - 1 -> void $ insertBy $ UserSupervisor s suid True + 1 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing 2 -> do - void $ insertBy $ UserSupervisor s suid True - void $ insertBy $ UserSupervisor suid suid True - 3 -> void $ insertBy $ UserSupervisor s suid True + void $ insertBy $ UserSupervisor s suid True Nothing (Just "Test") + void $ insertBy $ UserSupervisor suid suid True Nothing Nothing + 3 -> void $ insertBy $ UserSupervisor s suid True Nothing Nothing _ -> return () _ -> \_ _ -> return () expiryOffsets = concatMap (replicate usersPerDay) [0..(diffDays dto dfrom)] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3a0103c58..e42a02bf0 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity and HasUser instances + module Handler.Profile ( getProfileR, postProfileR , getForProfileR, postForProfileR @@ -622,12 +624,14 @@ makeProfileData (Entity uid User{..}) = do (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees' -- icnReroute = text2widget " " <> toWgt (icon IconLetter) --Tables - (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen + (hasRowsOwnedCourses, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen + supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors + superviseesTable <- mkSuperviseesTable uid -- Tabelle mit allen Supervisees let examTable, ownTutorialTable, tutorialTable :: Widget examTable = i18n MsgPersonalInfoExamAchievementsWip ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip @@ -1006,6 +1010,106 @@ mkQualificationsTable = } +-- Types & Definitions used for both mkSupervisorsTable and mkSuperviseeTable +type TblSupervisorExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserSupervisor) -- `E.LeftOuterJoin` E.SqlExpr (Entity Company) +type TblSupervisorData = DBRow (Entity User, Entity UserSupervisor) + +queryUser :: TblSupervisorExpr -> E.SqlExpr (Entity User) +queryUser = $(E.sqlIJproj 2 1) +queryUserSupervisor :: TblSupervisorExpr -> E.SqlExpr (Entity UserSupervisor) +queryUserSupervisor = $(E.sqlIJproj 2 2) +resultUser :: Lens' TblSupervisorData (Entity User) +resultUser = _dbrOutput . _1 +resultUserSupervisor :: Lens' TblSupervisorData (Entity UserSupervisor) +resultUserSupervisor = _dbrOutput . _2 + +instance HasEntity TblSupervisorData User where + hasEntity = _dbrOutput . _1 +instance HasUser TblSupervisorData where + hasUser = _dbrOutput . _1 . _entityVal + +-- | Table listing all supervisor of the given user +mkSupervisorsTable :: UserId -> DB Widget +mkSupervisorsTable uid = dbTableWidget' validator DBTable{..} + where + dbtIdent = "userSupervisedBy" :: Text + dbtStyle = def + + dbtSQLQuery (usr `E.InnerJoin` spr) = do + E.on $ spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.where_ $ spr E.^. UserSupervisorUser E.==. E.val uid + return (usr, spr) + dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId + dbtProj = dbtProjId + + dbtColonnade = mconcat + [ colUserNameModalHdr MsgTableSupervisor ForProfileDataR + , colUserEmail + , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b + , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) + , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell + ] + validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] + dbtSorting = mconcat + [ singletonMap & uncurry $ sortUserNameLink queryUser + , singletonMap & uncurry $ sortUserEmail queryUser + , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal) + , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications) + , singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany) + , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) + ] + dbtFilter = mconcat + [ singletonMap & uncurry $ fltrUserNameEmail queryUser + ] + dbtFilterUI = mempty + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + +-- | Table listing all persons supervised by the given user +mkSuperviseesTable :: UserId -> DB Widget +mkSuperviseesTable uid = dbTableWidget' validator DBTable{..} + where + dbtIdent = "userSupervisedBy" :: Text + dbtStyle = def + + dbtSQLQuery (usr `E.InnerJoin` spr) = do + E.on $ spr E.^. UserSupervisorUser E.==. usr E.^. UserId + E.where_ $ spr E.^. UserSupervisorSupervisor E.==. E.val uid + return (usr, spr) + dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId + dbtProj = dbtProjId + + dbtColonnade = mconcat + [ colUserNameModalHdr MsgTableSupervisee ForProfileDataR + -- , colUserEmail + -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b + , sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c) + , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell + ] + validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ] + dbtSorting = mconcat + [ singletonMap & uncurry $ sortUserNameLink queryUser + , singletonMap & uncurry $ sortUserEmail queryUser + , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal) + , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications) + , singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany) + , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason) + ] + dbtFilter = mconcat + [ singletonMap & uncurry $ fltrUserNameEmail queryUser + ] + dbtFilterUI = mempty + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + getAuthPredsR, postAuthPredsR :: Handler Html getAuthPredsR = postAuthPredsR postAuthPredsR = do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2af62ef7d..8ff0bd673 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -64,8 +64,8 @@ embedRenderMessage ''UniWorX ''UserAction id data UserActionData = UserLdapSyncData | UserHijack - | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } - | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } + | 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) @@ -192,9 +192,11 @@ postUsersR = do , singletonMap UserAddSupervisor $ UserAddSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) + <*> aopt textField (fslI MsgSupervisorReason) Nothing , singletonMap UserSetSupervisor $ UserSetSupervisorData <$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) + <*> aopt textField (fslI MsgSupervisorReason) Nothing , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData ] @@ -385,7 +387,7 @@ postUsersR = do nrSuperNotFound = length supersNotFound runDB $ do unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users] - putMany [UserSupervisor s u r + putMany [UserSupervisor s u r Nothing (getActionSupervisorReason act) | let r = getActionRerouteNotifications act , (_, Just s) <- supersFound , u <- users diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 90c3a3c0f..2d7cc6686 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -628,8 +628,9 @@ updateAvsUserByIds apids = do usr_ups = mcons eml_up $ frm_ups <> per_ups -- TODO: update Company -- cmp_up = let - -- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo) - -- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo) + -- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo) + -- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo) + -- in -- cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm ) -- cmp_new = (oldAvsFirmInfo ^. _avsFirmFirm ) diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 440f6c8fa..034ce56e1 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -15,14 +15,14 @@ import qualified Data.Text as Text import Database.Persist.Postgresql -- | Ensure that the given user is linked to the given company -upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () +upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking upsertUserCompany uid (Just cName) cAddr | notNull cName = do cid <- upsertCompany cName cAddr void $ upsertBy (UniqueUserCompany uid cid) (UserCompany uid cid False False) [] superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] - upsertManyWhere [ UserSupervisor super uid reroute + upsertManyWhere [ UserSupervisor super uid reroute (Just cid) Nothing | Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs ] [] [] [] upsertUserCompany uid _ _ = diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 223f58f28..4cd40a063 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -859,9 +859,15 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do return $ UserSupervisor E.<# E.val newUserId E.<&> (userSupervisor E.^. UserSupervisorUser) - E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) + E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) + E.<&> (userSupervisor E.^. UserSupervisorCompany) + E.<&> (userSupervisor E.^. UserSupervisorReason) ) - (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] ) + (\current excluded -> + [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) + , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] + , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] + ] ) deleteWhere [ UserSupervisorSupervisor ==. oldUserId] E.insertSelectWithConflict @@ -872,8 +878,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<# (userSupervisor E.^. UserSupervisorSupervisor) E.<&> E.val newUserId E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications) + E.<&> (userSupervisor E.^. UserSupervisorCompany) + E.<&> (userSupervisor E.^. UserSupervisorReason) ) - (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] ) + (\current excluded -> + [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) + , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] + , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] + ] ) deleteWhere [ UserSupervisorUser ==. oldUserId] -- Companies, in conflict, keep the newUser-Company as is diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 8e458ac47..4cc026a76 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -48,7 +48,8 @@ import qualified Data.Time.Zones as TZ data ManualMigration = Migration20230524QualificationUserBlock - | Migration20230703LmsUserStatus + | Migration20230703LmsUserStatus + | Migration20240124UniquenessCompanyAvsNr deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -97,7 +98,7 @@ migrateManual = do , ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")") , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") , ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company - , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user + , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user ] where addIndex :: Text -> Sql -> Migration @@ -177,6 +178,14 @@ customMigrations = mapF $ \case ; |] + Migration20240124UniquenessCompanyAvsNr -> + unlessM (indexExists "unique_company_avs_id") $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade + [executeQQ| + DELETE FROM "company" WHERE avs_id = 0; + ALTER TABLE "company" DROP CONSTRAINT IF EXISTS "unique_company_shorthand"; + |] + + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do @@ -218,3 +227,10 @@ columnNotExists :: MonadIO m -> Text -- ^ Column -> ReaderT SqlBackend m Bool columnNotExists table column = and2M (tableExists table) (not <$> columnExists table column) + +indexExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool +indexExists ixName = do + res <- [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|] + return $ case res of + [Single e] -> e + _other -> True diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 63fb8cf53..a81cdc33d 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -593,9 +593,9 @@ instance ToJSON AvsFirmCommunication where derivePersistFieldJSON ''AvsFirmCommunication data AvsFirmInfo = AvsFirmInfo - { avsFirmFirm :: Text + { avsFirmFirm :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende! , avsFirmFirmNo :: Int - , avsFirmAbbreviation :: Text -- enthält manchmal Leerzeichen! + , avsFirmAbbreviation :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende! , avsFirmZIPCode :: Maybe Text , avsFirmCity :: Maybe Text , avsFirmCountry :: Maybe Text @@ -629,9 +629,9 @@ _avsFirmPrimaryEmail = to mkEmail instance FromJSON AvsFirmInfo where parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo - <$> o .: "Firm" + <$> (o .: "Firm" <&> Text.strip) -- AVS may contain leading/trailing whitespace <*> o .: "FirmNo" - <*> o .: "Abbreviation" + <*> (o .: "Abbreviation" <&> Text.strip) -- AVS may contain leading/trailing whitespace <*> o .:?! "ZIPCode" <*> o .:?! "City" <*> o .:?! "Country" diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 5e5f993c6..e31590b44 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -113,6 +113,8 @@ makeClassyFor_ ''User -- _user... -- +makeClassyFor_ ''UserSupervisor + makeClassyFor_ ''StudyFeatures makeClassyFor_ ''StudyDegree diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 9eb2817af..8ab2bf8dd 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -191,7 +191,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
- $if hasRows + $if hasRowsOwnedCourses

_{MsgProfileCourses}
@@ -243,4 +243,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later \ _{MsgProfileCorrectorRemark} _{MsgProfileCorrections} +
+

_{MsgProfileSupervisor} +
+ ^{supervisorsTable} + +
+

_{MsgProfileSupervisee} +
+ ^{superviseesTable} + ^{profileRemarks} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 743c27e96..cecba6f38 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -681,21 +681,21 @@ fillDb = do -- void . insert' $ UserSupervisor svaupel gkleen False -- void . insert' $ UserSupervisor svaupel fhamann True -- void . insert' $ UserSupervisor sbarth tinaTester True - let supvs = [ UserSupervisor jost gkleen True - , UserSupervisor jost svaupel False - , UserSupervisor jost sbarth False - , UserSupervisor jost tinaTester True - , UserSupervisor jost jost True - , UserSupervisor svaupel gkleen False - , UserSupervisor svaupel fhamann True - , UserSupervisor sbarth tinaTester True - , UserSupervisor gkleen fhamann False - , UserSupervisor gkleen gkleen True - , UserSupervisor tinaTester tinaTester False + let supvs = [ UserSupervisor jost gkleen True (Just fraportAg) (Just "Staff") + , UserSupervisor jost svaupel False (Just fraportAg) (Just "Staff") + , UserSupervisor jost sbarth False (Just fraportAg) (Just "Staff") + , UserSupervisor jost tinaTester True (Just fraportAg) (Just "Staff") + , UserSupervisor jost jost True (Just fraportAg) (Just "Staff") + , UserSupervisor svaupel gkleen False (Just nice) (Just "Staff") + , UserSupervisor svaupel fhamann True (Just nice) (Just "Staff") + , UserSupervisor sbarth tinaTester True (Just nice) (Just "Staff") + , UserSupervisor gkleen fhamann False (Just fraGround) (Just "Staff") + , UserSupervisor gkleen gkleen True (Just fraGround) (Just "Staff") + , UserSupervisor tinaTester tinaTester False Nothing (Just "Staff") ] - ++ take 444 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost] - ++ take 123 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 369 matUsers ] - ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ] + ++ take 444 [ UserSupervisor fhamann uid True Nothing (Just "Test") | Entity uid _ <- matUsers, uid /= jost] + ++ take 123 [ UserSupervisor gkleen uid True (Just fraGround) (Just "Test") | Entity uid _ <- drop 369 matUsers ] + ++ take 11 [ UserSupervisor jost uid False (Just fraportAg) (Just "Test") | Entity uid _ <- drop 501 matUsers ] upsertManyWhere supvs [] [] [] -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- insertMany_ supvs -- NOTE: multiple calls like this throw an error! -- 2.39.2 From f439ea45af9b1c4a029fc1b9b6383f3c97194ed0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 23 Jan 2024 19:20:32 +0100 Subject: [PATCH 11/85] fix(build): migration needs to check for table existens first --- src/Model/Migration/Definitions.hs | 2 +- src/Utils.hs | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 4cc026a76..470145d6e 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -179,7 +179,7 @@ customMigrations = mapF $ \case |] Migration20240124UniquenessCompanyAvsNr -> - unlessM (indexExists "unique_company_avs_id") $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade + whenM (tableExists "company" `and2M` notM (indexExists "unique_company_avs_id")) $ do -- companies with avs_id == 0 can be deleted; company users are deleted automatically by cascade [executeQQ| DELETE FROM "company" WHERE avs_id = 0; ALTER TABLE "company" DROP CONSTRAINT IF EXISTS "unique_company_shorthand"; diff --git a/src/Utils.hs b/src/Utils.hs index 5ae894f30..54338f381 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1196,6 +1196,9 @@ ifM c x y = c >>= bool y x ifNotM :: Monad m => m Bool -> m a -> m a -> m a ifNotM c = flip $ ifM c +notM :: Functor f => f Bool -> f Bool +notM = fmap not + -- | Short-circuiting monadic boolean function, copied from Andreas Abel's utility function and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool and2M ma mb = ifM ma mb (return False) -- 2.39.2 From 482dbe5c4e680e81eeb7a72c6ef1676a98738851 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 17:38:53 +0100 Subject: [PATCH 12/85] chore(dbtable): add FilterColumnIO and proof-of-concept This commit adds a new type of filter to dbtables in module Pagination. The filter can perform an arbitrary IO action on its arguments before producing an sql/esqueleto filter expression. Also, we turn some unnecessarily monadic code pure. --- src/Handler/Qualification.hs | 25 ++++++++++++++++++------- src/Handler/Utils/Table/Pagination.hs | 26 ++++++++++++++++++++++---- 2 files changed, 40 insertions(+), 11 deletions(-) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 5b2c315af..28ffdecea 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -410,13 +410,24 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) - , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of - Nothing -> E.false - Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do - E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId - E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId - E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) - ) + -- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of + -- Nothing -> E.false + -- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do + -- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId + -- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + -- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) + -- ) + -- , single ("avs-card" , FilterColumnIO $ \(queryUser -> user) (criterion :: [Text]) -> const (return E.true :: IO (E.SqlExpr (E.Value Bool))) -- putStrLn "******** IT WORKS *****************" + , single ("avs-card" , FilterColumnIO $ \(criteria :: [Text]) -> + case criteria of + [] -> return (const E.true) :: IO (QualificationTableExpr -> E.SqlExpr (E.Value Bool)) + xs -> do + putStrLn "******** IT WORKS *****************" + putStrLn $ tshow (length xs) <> ": " <> T.intercalate ", " criteria + putStrLn "******** IT WORKS *****************" + return $ \(queryUser-> user) -> + user E.^. UserFirstName `E.in_` E.vals xs + ) , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 0bca321ac..d573f139e 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -22,7 +22,7 @@ module Handler.Utils.Table.Pagination , SortColumn(..), SortDirection(..) , SortingSetting(..) , pattern SortAscBy, pattern SortDescBy - , FilterColumn(..), IsFilterColumn, IsFilterProjected + , FilterColumn(..), IsFilterColumn, IsFilterColumnIO, IsFilterProjected , mkFilterProjectedPost , DBTProjFilterPost(..) , DBRow(..), _dbrOutput, _dbrCount @@ -262,12 +262,18 @@ instance Monoid (DBTProjFilterPost r') where data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a + | forall a. IsFilterColumnIO t a => FilterColumnIO a | forall a. IsFilterProjected fs a => FilterProjected a + filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool)) filterColumn (FilterColumn f) = Just $ filterColumn' f filterColumn _ = Nothing +filterColumnIO :: FilterColumn t fs -> Maybe ([Text] -> IO (t -> E.SqlExpr (E.Value Bool))) +filterColumnIO (FilterColumnIO f) = Just $ filterColumnIO' f +filterColumnIO _ = Nothing + filterProjected :: FilterColumn t fs -> [Text] -> (fs -> fs) filterProjected (FilterProjected f) = filterProjected' f filterProjected _ = const id @@ -287,6 +293,12 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is' +class IsFilterColumnIO t a where + filterColumnIO' :: a -> [Text] -> IO (t -> E.SqlExpr (E.Value Bool)) + +instance IsFilterColumnIO t ([Text] -> IO (t -> E.SqlExpr (E.Value Bool))) where + filterColumnIO' fin args = fin args + class IsFilterProjected fs a where filterProjected' :: a -> [Text] -> (fs -> fs) @@ -1198,7 +1210,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db sortSql :: _ -> [E.SqlExpr E.OrderBy] sortSql t = concatMap (\(f, d) -> f d t) $ mapMaybe (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting' - filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool))) + filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool))) -- could there be any reason not to remove Nothing values from the map already here? filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter' -- selectPagesize = primarySortSql @@ -1206,6 +1218,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -- psLimit' = bool PagesizeAll psLimit selectPagesize + filterIO <- case csvMode of + FormSuccess DBCsvImport{} -> return mempty -- don't execute IO actions for unneeded filters upon csv _import_ + _other -> liftIO $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnIO fc -- TODO: add timeout + rows' <- E.select . E.from $ \t -> do res <- dbtSQLQuery t E.orderBy $ sortSql t @@ -1221,9 +1237,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> do E.limit l E.offset $ psPage * l - Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps + Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps -- Note that multiple where_ are indeed concatenated _other -> return () - Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql + let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) [] + sqlFilters = filterAppT filterIO <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both + unless (null sqlFilters) $ E.where_ $ E.and sqlFilters return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v -- 2.39.2 From d4f7dce716e2cccd199675e9288ad59960cf0630 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 18:44:14 +0100 Subject: [PATCH 13/85] chore(avs): card no filter basic functionality WIP compiles --- src/Audit.hs | 2 +- src/Handler/Firm.hs | 2 +- src/Handler/Qualification.hs | 23 ++++++++++------- src/Handler/Utils/Avs.hs | 37 +++++++++++++++++++++------ src/Handler/Utils/Table/Pagination.hs | 28 ++++++++++---------- src/Model/Types/Avs.hs | 36 ++++++++++++++++---------- src/Utils/Avs.hs | 15 ++++++++++- 7 files changed, 95 insertions(+), 48 deletions(-) diff --git a/src/Audit.hs b/src/Audit.hs index e13c769b9..1637ffc1f 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -130,7 +130,7 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User logInterface interfaceLogInterface interfaceLogSubtype interfaceLogRows interfaceLogInfo = do interfaceLogTime <- liftIO getCurrentTime interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest - deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest + deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert is correct here, since we want to repalce the it insert_ InterfaceLog{..} audit TransactionInterface { transactionInterfaceName = interfaceLogInterface diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 0d68a958f..8c25f0572 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -619,7 +619,7 @@ mkFirmAllTable isAdmin uid = do case criterion of Nothing -> return True :: DB Bool (Just (crit::Text)) -> do - critFirms <- memcachedBy (Just . Right $ 1 * diffMinute) ("SVR:"<>crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do + critFirms <- memcachedBy (Just . Right $ 3 * diffMinute) ("SVR:"<>crit) $ fmap (Set.fromList . fmap E.unValue) $ E.select $ E.distinct $ do (usr :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @Company `E.on` (\(usr :& cmp) -> E.exists (do usrCmp <- E.from $ E.table @UserCompany diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 28ffdecea..104dbc7b2 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -18,7 +18,7 @@ import Import import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS - +import Handler.Utils.Avs (queryAvsCardNos) import qualified Data.Set as Set import qualified Data.Map as Map @@ -418,15 +418,20 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do -- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) -- ) -- , single ("avs-card" , FilterColumnIO $ \(queryUser -> user) (criterion :: [Text]) -> const (return E.true :: IO (E.SqlExpr (E.Value Bool))) -- putStrLn "******** IT WORKS *****************" - , single ("avs-card" , FilterColumnIO $ \(criteria :: [Text]) -> + , single ("avs-card" , FilterColumnHandler $ \(criteria :: [Text]) -> case criteria of - [] -> return (const E.true) :: IO (QualificationTableExpr -> E.SqlExpr (E.Value Bool)) + [] -> return (const E.true) :: Handler (QualificationTableExpr -> E.SqlExpr (E.Value Bool)) xs -> do - putStrLn "******** IT WORKS *****************" - putStrLn $ tshow (length xs) <> ": " <> T.intercalate ", " criteria - putStrLn "******** IT WORKS *****************" - return $ \(queryUser-> user) -> - user E.^. UserFirstName `E.in_` E.vals xs + apids <- queryAvsCardNos $ mapMaybe parseAvsCardNo xs -- $ foldMap cfAnySeparatedSet xs TODO + if null apids + then + -- addMessageI ??? + return (const E.false) + else + return $ \(queryUser-> user) -> + E.exists $ E.from $ \usrAvs -> + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + E.&&. usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids ) , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true @@ -458,7 +463,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) -- & cfAnySeparatedSet , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 2d7cc6686..63dfbc9d0 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -22,6 +22,8 @@ module Handler.Utils.Avs , AvsException(..) , updateReceivers , AvsPersonIdMapPersonCard + -- CR3 + , queryAvsCardNo, queryAvsCardNos ) where import Import @@ -41,6 +43,7 @@ import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionExce import Handler.Utils.Company import Handler.Utils.Qualification +import Handler.Utils.Memcached import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma @@ -160,7 +163,6 @@ setLicencesAvs persLics = do -- exceptT (return 0 <$ addMessage Error . text2Htm -- | Retrieve all currently valid driving licences and check against our database -- Only react to changes as compared to last seen status in avs.model --- TODO: run in a background job, once the interface is actually available synchAvsLicences :: Handler Bool synchAvsLicences = do AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery @@ -340,7 +342,7 @@ guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoT guessAvsUser someid = do let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard case discernAvsCardPersonalNo someid of - Just cid@(Left _cardNo) -> maybeUpsertAvsUserByCard cid + Just cid@(Right _cardNo) -> maybeUpsertAvsUserByCard cid -- NOTE: card validity might be outdated, so we must always check with avs -- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do -- let extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid @@ -349,7 +351,7 @@ guessAvsUser someid = do -- case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of -- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard) -- _ -> return Nothing - Just cid@(Right _wholeNumber) -> + Just cid@(Left _wholeNumber) -> maybeUpsertAvsUserByCard cid >>= \case Nothing -> runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case @@ -358,7 +360,7 @@ guessAvsUser someid = do uid -> return uid Nothing -> try (runDB $ ldapLookupAndUpsert someid) >>= \case Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> - maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)) + maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Left $ mkAvsInternalPersonalNo persNo)) Right Entity{entityKey=uid} -> return $ Just uid other -> do -- attempt to recover by trying other ids whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all @@ -372,7 +374,7 @@ upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail try (runDB $ ldapLookupAndUpsert otherId) >>= \case - Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) + Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Left $ mkAvsInternalPersonalNo persNo) other -> do -- attempt to recover by trying other ids whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all apid <- runDB . runMaybeT $ do @@ -385,11 +387,11 @@ upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail -- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update. -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. -upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! +upsertAvsUserByCard :: Either AvsInternalPersonalNo AvsFullCardNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! upsertAvsUserByCard persNo = do let qry = case persNo of - Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } - Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn } + Right AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } + Left fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn } AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry case Set.elems adps of @@ -571,6 +573,25 @@ updateReceivers uid = do ------------------ -- CR3 Functions +queryAvsCardNos :: Foldable t => t (Either AvsCardNo AvsFullCardNo) -> Handler (Set AvsPersonId) +queryAvsCardNos = foldMapM queryAvsCardNo + +queryAvsCardNo :: Either AvsCardNo AvsFullCardNo -> Handler (Set AvsPersonId) +queryAvsCardNo crd = do + AvsResponsePerson adps <- avsPersonQueryCached $ qry crd + return $ Set.map avsPersonPersonID adps + where + qry (Left acno) = def{ avsPersonQueryCardNo = Just acno } + qry (Right AvsFullCardNo{..}) = def{ avsPersonQueryCardNo = Just avsFullCardNo + , avsPersonQueryVersionNo = Just avsFullCardVersion + } + +avsPersonQueryCached :: AvsQueryPerson -> Handler AvsResponsePerson +avsPersonQueryCached apq = memcachedBy (Just . Right $ 5 * diffMinute) apq $ do -- TODO using settings for time + AvsQuery{avsQueryPerson} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + throwLeftM $ avsQueryPerson apq + + -- A datatype for a specific heterogeneous list -- data CheckAvsUpdate record iavs = forall typ f. (Eq typ, PersistField typ, Functor f) => CheckAvsUpdate (EntityField record typ) ((typ -> f typ) -> iavs -> f iavs) -- An Record Field and fitting Lens data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) ((typ -> Const typ typ) -> iavs -> Const typ iavs) -- An Record Field and fitting Lens diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index d573f139e..fe14123eb 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -22,7 +22,7 @@ module Handler.Utils.Table.Pagination , SortColumn(..), SortDirection(..) , SortingSetting(..) , pattern SortAscBy, pattern SortDescBy - , FilterColumn(..), IsFilterColumn, IsFilterColumnIO, IsFilterProjected + , FilterColumn(..), IsFilterColumn, IsFilterColumnHandler, IsFilterProjected , mkFilterProjectedPost , DBTProjFilterPost(..) , DBRow(..), _dbrOutput, _dbrCount @@ -262,7 +262,7 @@ instance Monoid (DBTProjFilterPost r') where data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a - | forall a. IsFilterColumnIO t a => FilterColumnIO a + | forall a. IsFilterColumnHandler t a => FilterColumnHandler a | forall a. IsFilterProjected fs a => FilterProjected a @@ -270,9 +270,9 @@ filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bo filterColumn (FilterColumn f) = Just $ filterColumn' f filterColumn _ = Nothing -filterColumnIO :: FilterColumn t fs -> Maybe ([Text] -> IO (t -> E.SqlExpr (E.Value Bool))) -filterColumnIO (FilterColumnIO f) = Just $ filterColumnIO' f -filterColumnIO _ = Nothing +filterColumnHandler :: FilterColumn t fs -> Maybe ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) +filterColumnHandler (FilterColumnHandler f) = Just $ filterColumnHandler' f +filterColumnHandler _ = Nothing filterProjected :: FilterColumn t fs -> [Text] -> (fs -> fs) filterProjected (FilterProjected f) = filterProjected' f @@ -293,11 +293,11 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is' -class IsFilterColumnIO t a where - filterColumnIO' :: a -> [Text] -> IO (t -> E.SqlExpr (E.Value Bool)) +class IsFilterColumnHandler t a where + filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool)) -instance IsFilterColumnIO t ([Text] -> IO (t -> E.SqlExpr (E.Value Bool))) where - filterColumnIO' fin args = fin args +instance IsFilterColumnHandler t ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) where + filterColumnHandler' fin args = fin args class IsFilterProjected fs a where filterProjected' :: a -> [Text] -> (fs -> fs) @@ -1217,10 +1217,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -- && all (is _Just) filterSql -- psLimit' = bool PagesizeAll psLimit selectPagesize - - filterIO <- case csvMode of - FormSuccess DBCsvImport{} -> return mempty -- don't execute IO actions for unneeded filters upon csv _import_ - _other -> liftIO $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnIO fc -- TODO: add timeout + + filterHandler <- case csvMode of + FormSuccess DBCsvImport{} -> return mempty -- don't execute Handler actions for unneeded filters upon csv _import_ + _other -> liftHandler $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnHandler fc rows' <- E.select . E.from $ \t -> do res <- dbtSQLQuery t @@ -1240,7 +1240,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps -- Note that multiple where_ are indeed concatenated _other -> return () let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) [] - sqlFilters = filterAppT filterIO <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both + sqlFilters = filterAppT filterHandler <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both unless (null sqlFilters) $ E.where_ $ E.and sqlFilters return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index a81cdc33d..1ae912248 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -100,7 +100,7 @@ composeAddress street zipcode city country = toMaybe (notNull compAddr) compAddr newtype AvsInternalPersonalNo = AvsInternalPersonalNo { avsInternalPersonalNo :: Text } -- ought to be all digits deriving (Eq, Ord, Show, Generic) - deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) + deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Binary) instance E.SqlString AvsInternalPersonalNo -- AvsInternalPersonalNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API @@ -160,7 +160,7 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where type AvsVersionNo = Text -- always 1 digit newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits -- TODO: Create Smart Constructor deriving (Eq, Ord, Show, Generic) - deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField) + deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField, Binary) -- No longer needed: -- deriving newtype (PersistField, PersistFieldSql) -- instance E.SqlString AvsCardNo @@ -203,15 +203,22 @@ instance PersistField AvsFullCardNo where instance PersistFieldSql AvsFullCardNo where sqlType _ = SqlString -discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point -discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv)) +parseAvsCardNo :: Text -> Maybe (Either AvsCardNo AvsFullCardNo) +parseAvsCardNo = splitDigitsByDot AvsCardNo (AvsFullCardNo . AvsCardNo) + +discernAvsCardPersonalNo :: Text -> Maybe (Either AvsInternalPersonalNo AvsFullCardNo) +discernAvsCardPersonalNo = splitDigitsByDot mkAvsInternalPersonalNo (AvsFullCardNo . AvsCardNo) + +-- | Just implies that argument is a whole number or decimal with one single digit after the point. Helper functions receive digit-parts without dot +splitDigitsByDot :: (Text -> a) -> (Text -> Text -> b) -> Text -> Maybe (Either a b) +splitDigitsByDot fl fr (Text.span Char.isDigit -> (c, pv)) + | Text.null c = Nothing | Text.null pv - = Just $ Right $ mkAvsInternalPersonalNo c - | not $ Text.null c - , Just ('.', v) <- Text.uncons pv + = Just $ Left $ fl c + | Just ('.', v) <- Text.uncons pv , Just (Char.isDigit -> True, "") <- Text.uncons v - = Just $ Left $ AvsFullCardNo (AvsCardNo c) v -discernAvsCardPersonalNo _ = Nothing + = Just $ Right $ fr c v +splitDigitsByDot _ _ _ = Nothing -- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId` newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int @@ -303,7 +310,7 @@ licence2char AvsLicenceRollfeld = 'R' data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Read, Show, Generic, Binary) deriving anyclass (NFData) -- instance RenderMessage declared in Foundation.I18n @@ -337,7 +344,7 @@ data AvsDataPersonCard = AvsDataPersonCard , avsDataCardNo :: AvsCardNo -- always 8 digits number, prefixed with 0 , avsDataVersionNo :: AvsVersionNo -- always 1 digit number } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic,Binary) deriving anyclass (NFData) {- Automatically derived Ord instance should prioritize avsDataValid and avsDataValidTo. Checked in test/Model.TypesSpec @@ -431,7 +438,7 @@ data AvsDataPerson = AvsDataPerson , avsPersonPersonID :: AvsPersonId -- Eindeutige PersonenID, wichtig für die Schnittstelle! , avsPersonPersonCards :: Set AvsDataPersonCard } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, NFData, Binary) makeLenses_ ''AvsDataPerson @@ -696,7 +703,8 @@ instance Semigroup AvsResponseStatus where (AvsResponseStatus a) <> (AvsResponseStatus b) = AvsResponseStatus (a <> b) newtype AvsResponsePerson = AvsResponsePerson (Set AvsDataPerson) - deriving (Eq, Ord, Show, Generic) + deriving (Show, Generic) + deriving newtype (Eq, Ord, NFData, Binary) -- makeWrapped ''AvsResponsePerson deriveJSON defaultOptions { fieldLabelModifier = dropCamel 2 @@ -749,7 +757,7 @@ data AvsQueryPerson = AvsQueryPerson , avsPersonQueryLastName :: Maybe Text , avsPersonQueryInternalPersonalNo :: Maybe AvsInternalPersonalNo } - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, NFData, Binary) instance Default AvsQueryPerson where def = AvsQueryPerson Nothing Nothing Nothing Nothing Nothing diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 7f6f0d696..b20ef42f1 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -70,7 +70,20 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery #ifdef DEVELOPMENT mkAvsQuery _ _ _ = AvsQuery - { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty + { avsQueryPerson = + let + sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty + stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty + steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty + + in \case + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson steffen + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> return . Right $ AvsResponsePerson steffen + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson stephan + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> return . Right $ AvsResponsePerson sarah + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> return . Right $ AvsResponsePerson $ steffen <> sarah + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson $ steffen <> stephan + _ -> return . Right $ AvsResponsePerson mempty , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing Nothing) , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty -- 2.39.2 From 64797536e3db699fc19828acd80a9cf57130e75f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 13 Feb 2024 10:05:50 +0100 Subject: [PATCH 14/85] refactor(qualification): card filter accepts multiple cards now --- src/Database/Esqueleto/Utils.hs | 16 ++++++++-------- src/Handler/Qualification.hs | 11 +++++------ src/Utils.hs | 6 ++++++ 3 files changed, 19 insertions(+), 14 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 1e8ecfe7e..63f41363e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -347,7 +347,7 @@ mkExactFilterMaybeLast' lensexists lenslike row criterias -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements -- (Keep Set here to ensure that there are no duplicates) -mkContainsFilter :: E.SqlString a +mkContainsFilter :: (E.SqlString a, Ord a) => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element -> t -- ^ query row -> Set.Set a -- ^ needle collection @@ -355,7 +355,7 @@ mkContainsFilter :: E.SqlString a mkContainsFilter = mkContainsFilterWith id -- | like `mkContainsFilter` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` -mkContainsFilterWith :: E.SqlString b +mkContainsFilterWith :: (E.SqlString b, Ord a) => (a -> b) -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element -> t -- ^ query row @@ -363,7 +363,7 @@ mkContainsFilterWith :: E.SqlString b -> E.SqlExpr (E.Value Bool) mkContainsFilterWith cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias -- | like `mkContainsFilterWith` but allows conversion to produce multiple needles mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a) @@ -374,7 +374,7 @@ mkContainsFilterWithSet :: (E.SqlString b, Ord b, Ord a) -> E.SqlExpr (E.Value Bool) mkContainsFilterWithSet cast lenslike row criterias | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val <$> Set.toList (foldMap cast criterias)) + | otherwise = any (hasInfix (lenslike row) . E.val) (foldMap cast criterias) -- | like `mkContainsFilterWithSet` but fixed to comma separated Texts mkContainsFilterWithComma :: (E.SqlString b, Ord b) @@ -385,7 +385,7 @@ mkContainsFilterWithComma :: (E.SqlString b, Ord b) -> E.SqlExpr (E.Value Bool) mkContainsFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias) + | otherwise = any (hasInfix (lenslike row) . E.val . cast) criterias -- | like `mkContainsFilterWithComma` but enforced the existence of all Texts prefixed with + mkContainsFilterWithCommaPlus :: (E.SqlString b, Ord b) @@ -401,8 +401,8 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c | otherwise = cond_compulsory E.&&. cond_optional where (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias - cond_compulsory = all (hasInfix $ lenslike row) (E.val . cast <$> Set.toList compulsories) - cond_optional = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList alternatives) + cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories + cond_optional = any (hasInfix (lenslike row) . E.val . cast) alternatives mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime)) -- ^ getter from query to searched element -> t -- ^ query row @@ -447,7 +447,7 @@ mkExistsFilterWithComma :: PathPiece a -> E.SqlExpr (E.Value Bool) mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = any (E.exists . query row) (cast <$> Set.toList criterias) + | otherwise = any (E.exists . query row . cast) criterias -- | Combine several filters, using logical or diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 104dbc7b2..bb24e8102 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -416,16 +416,15 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do -- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId -- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId -- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) - -- ) - -- , single ("avs-card" , FilterColumnIO $ \(queryUser -> user) (criterion :: [Text]) -> const (return E.true :: IO (E.SqlExpr (E.Value Bool))) -- putStrLn "******** IT WORKS *****************" + -- ) , single ("avs-card" , FilterColumnHandler $ \(criteria :: [Text]) -> case criteria of [] -> return (const E.true) :: Handler (QualificationTableExpr -> E.SqlExpr (E.Value Bool)) xs -> do - apids <- queryAvsCardNos $ mapMaybe parseAvsCardNo xs -- $ foldMap cfAnySeparatedSet xs TODO + let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText xs + apids <- queryAvsCardNos crds if null apids - then - -- addMessageI ??? + then return (const E.false) else return $ \(queryUser-> user) -> @@ -463,7 +462,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) -- & cfAnySeparatedSet + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo & setTooltip MsgTableFilterComma) , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty diff --git a/src/Utils.hs b/src/Utils.hs index 54338f381..af114c216 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -526,6 +526,12 @@ textUnlines = Text.intercalate $ Text.singleton '\n' commaSeparatedText :: Text -> Set Text commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',') +-- also see Utils.Form.cfAnySeparatedSet +anySeparatedText :: Text -> Set Text +anySeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split anySeparator + where anySeparator :: Char -> Bool + anySeparator c = Char.isSeparator c || c == ',' || c == ';' + ----------- -- Fixed -- -- 2.39.2 From 99adff80cded8838117f3a4b6be61b5887d162f2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 13 Feb 2024 13:39:28 +0100 Subject: [PATCH 15/85] chore(avs): add timeout to cardno filter --- .../uniworx/categories/avs/de-de-formal.msg | 2 ++ messages/uniworx/categories/avs/en-eu.msg | 2 ++ src/Handler/Qualification.hs | 30 +++++++++---------- src/Utils.hs | 4 +-- 4 files changed, 21 insertions(+), 17 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index bd5c01716..fd3b39fa8 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -9,6 +9,7 @@ AvsFirstName: Vorname AvsLastName: Nachname AvsInternalPersonalNo: Personalnummer (nur Fraport AG) AvsVersionNo: Versionsnummer +AvsQueryNeeded: Benötigt Verbindung zum AVS. AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen! AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t} AvsLicence: Fahrberechtigung @@ -27,6 +28,7 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} in FRADrive entzogen für RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler. +AvsCommunicationTimeout: AVS Schnittstelle antwortete nicht. LicenceTableChangeAvs: Im AVS ändern LicenceTableGrantFDrive: In FRADrive erteilen LicenceTableRevokeFDrive: In FRADrive entziehen diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index ec7288d7d..ccaeb9012 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -9,6 +9,7 @@ AvsFirstName: First name AvsLastName: Last name AvsInternalPersonalNo: Personnel number (Fraport AG only) AvsVersionNo: Version number +AvsQueryNeeded: AVS connection required. AvsQueryEmpty: At least one query field must be filled! AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t} AvsLicence: Driving Licence @@ -27,6 +28,7 @@ RevokeFraDriveLicences alic@AvsLicence n@Int: _{alic} revoked in FRADrive for #{ RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details AvsCommunicationError: AVS interface returned an unexpected error. +AvsCommunicationTimeout: AVS interface returned no response within timeout limit. LicenceTableChangeAvs: Change in AVS LicenceTableGrantFDrive: Grant in FRADrive LicenceTableRevokeFDrive: Revoke in FRADrive diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index bb24e8102..67a7e4bd6 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -19,6 +19,7 @@ import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS import Handler.Utils.Avs (queryAvsCardNos) +import Handler.Utils.Concurrent import qualified Data.Set as Set import qualified Data.Map as Map @@ -417,20 +418,19 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do -- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId -- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) -- ) - , single ("avs-card" , FilterColumnHandler $ \(criteria :: [Text]) -> - case criteria of - [] -> return (const E.true) :: Handler (QualificationTableExpr -> E.SqlExpr (E.Value Bool)) - xs -> do - let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText xs - apids <- queryAvsCardNos crds - if null apids - then - return (const E.false) - else - return $ \(queryUser-> user) -> - E.exists $ E.from $ \usrAvs -> - E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId - E.&&. usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids + , single ("avs-card" , FilterColumnHandler $ \case + [] -> return (const E.true) :: Handler (QualificationTableExpr -> E.SqlExpr (E.Value Bool)) + cs -> + let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs + in timeoutHandler (0 * 30 * 1000000) (queryAvsCardNos crds) >>= \case + Nothing -> addMessageI Error MsgAvsCommunicationTimeout + >> return (const E.false) + (Just (null -> True)) -> return (const E.false) + (Just apids) -> return $ + \(queryUser -> user) -> + E.exists $ E.from $ \usrAvs -> + E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId + E.&&. usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids ) , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true @@ -462,7 +462,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo & setTooltip MsgTableFilterComma) + , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo & setTooltip SomeMessages [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded]) , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty diff --git a/src/Utils.hs b/src/Utils.hs index f0440caa5..79a7bfd66 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -534,8 +534,8 @@ commaSeparatedText :: Text -> Set Text commaSeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split (==',') -- also see Utils.Form.cfAnySeparatedSet -anySeparatedText :: Text -> Set Text -anySeparatedText = Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split anySeparator +anySeparatedText :: Text -> [Text] +anySeparatedText = mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.split anySeparator where anySeparator :: Char -> Bool anySeparator c = Char.isSeparator c || c == ',' || c == ';' -- 2.39.2 From ef36e22f7617bdf7910f606002c871a46f763cc1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 13 Feb 2024 16:25:58 +0100 Subject: [PATCH 16/85] chore(avs): make avs timeouts setting configurable --- config/settings.yml | 10 ++++++---- src/Handler/Admin/Avs.hs | 10 +++++++++- src/Handler/Qualification.hs | 7 ++++--- src/Handler/Utils/Avs.hs | 8 +++++--- src/Handler/Utils/Concurrent.hs | 6 ++++++ src/Settings.hs | 14 ++++++++++---- 6 files changed, 40 insertions(+), 15 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 68bed4958..b3b61a502 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -157,10 +157,12 @@ lms-direct: deletion-days: "_env:LMSDELETIONDAYS:7" avs: - host: "_env:AVSHOST:skytest.fra.fraport.de" - port: "_env:AVSPORT:443" - user: "_env:AVSUSER:fradrive" - pass: "_env:AVSPASS:" + host: "_env:AVSHOST:skytest.fra.fraport.de" + port: "_env:AVSPORT:443" + user: "_env:AVSUSER:fradrive" + pass: "_env:AVSPASS:" + timeout: "_env:AVSTIMEOUT:42" + cache-expiry: "_env:AVSCACHEEXPIRY:420" lpr: host: "_env:LPRHOST:fravm017173.fra.fraport.de" diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 871ee1634..836e7e6dc 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -140,7 +140,15 @@ postAdminAvsR = do mbAvsConf <- getsYesod $ view _appAvsConf let avsWgt = [whamlet| $maybe avsConf <- mbAvsConf - AVS Konfiguration ist #{decodeUtf8 (avsUser avsConf)}@#{avsHost avsConf}:#{avsPort avsConf} +

+ AVS Konfiguration +