updateAvsUser (partial) requires migration
This commit is contained in:
parent
b566e59eb1
commit
61aba7e515
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user