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)