chore(avs): prepare function to update all letter receivers
This commit is contained in:
Steffen Jost
parent
612fd9284b
commit
1686a96cc5
@ -13,6 +13,7 @@ module Handler.Utils.Avs
|
||||
, synchAvsLicences
|
||||
, lookupAvsUser, lookupAvsUsers
|
||||
, AvsException(..)
|
||||
, updateReceivers
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -69,7 +70,7 @@ instance Exception AvsException
|
||||
|
||||
-}
|
||||
|
||||
{- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround
|
||||
{- AVS interface only allows collecting all licences at once, thus getLicence should be avoided, see getLicenceByAvsId including a workaround
|
||||
-- Do we need this?
|
||||
-- getLicence :: UserId -> Handler (Maybe AvsLicence) -- with runDB
|
||||
getLicence :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) => UserId -> m (Maybe AvsLicence)
|
||||
@ -107,7 +108,7 @@ setLicence uid lic = do
|
||||
Entity _ UserAvs{..} <- maybeThrowM (AvsUserUnassociated uid) $ getBy $ UniqueUserAvsUser uid
|
||||
setLicenceAvs userAvsPersonId lic
|
||||
|
||||
setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
||||
setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
||||
AvsPersonId -> AvsLicence -> m Bool
|
||||
setLicenceAvs apid lic = do
|
||||
let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
|
||||
@ -119,12 +120,12 @@ setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
|
||||
Set AvsPersonLicence -> m Bool
|
||||
setLicencesAvs persLics = do
|
||||
AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
aux aqsl True persLics
|
||||
where
|
||||
aux aqsl True persLics
|
||||
where
|
||||
aux aqsl batch0_ok pls
|
||||
| Set.null pls = return batch0_ok
|
||||
| otherwise = do
|
||||
let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls
|
||||
| otherwise = do
|
||||
let (batch1, batch2) = Set.splitAt avsMaxSetLicenceAtOnce pls
|
||||
response <- throwLeftM $ aqsl $ AvsQuerySetLicences batch1
|
||||
case response of
|
||||
AvsResponseSetLicencesError{..} -> do
|
||||
@ -134,7 +135,7 @@ setLicencesAvs persLics = do
|
||||
|
||||
AvsResponseSetLicences msgs -> do
|
||||
let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs
|
||||
ok_ids = Set.map avsResponsePersonID ok
|
||||
ok_ids = Set.map avsResponsePersonID ok
|
||||
bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
|
||||
batch1_ok = length ok == length batch1
|
||||
forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
|
||||
@ -147,7 +148,7 @@ setLicencesAvs persLics = do
|
||||
-- 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
|
||||
synchAvsLicences = do
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
allLicences <- throwLeftM avsQueryGetAllLicences
|
||||
deltaLicences <- computeDifferingLicences allLicences
|
||||
@ -161,21 +162,21 @@ computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLice
|
||||
computeDifferingLicences argl = do
|
||||
(setTo0, setTo1, setTo2) <- getDifferingLicences argl
|
||||
return $ Set.map (AvsPersonLicence AvsNoLicence) setTo0
|
||||
<> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1
|
||||
<> Set.map (AvsPersonLicence AvsLicenceVorfeld) setTo1
|
||||
<> Set.map (AvsPersonLicence AvsLicenceRollfeld) setTo2
|
||||
|
||||
retrieveDifferingLicences :: Handler (Set AvsPersonId, Set AvsPersonId, Set AvsPersonId)
|
||||
retrieveDifferingLicences = do
|
||||
retrieveDifferingLicences = do
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
allLicences <- throwLeftM avsQueryGetAllLicences
|
||||
getDifferingLicences allLicences
|
||||
getDifferingLicences allLicences
|
||||
|
||||
getDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonId, Set AvsPersonId, Set AvsPersonId)
|
||||
getDifferingLicences (AvsResponseGetLicences licences) = do
|
||||
now <- liftIO getCurrentTime
|
||||
--let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences
|
||||
-- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
|
||||
-- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
|
||||
-- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
|
||||
let nowaday = utctDay now
|
||||
noOne = AvsPersonId 0
|
||||
vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences
|
||||
@ -184,18 +185,18 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
|
||||
rollfeld = Set.map avsLicencePersonID rollfeld'
|
||||
|
||||
antijoinAvsLicences :: AvsLicence -> Set AvsPersonId -> DB (Set AvsPersonId,Set AvsPersonId)
|
||||
antijoinAvsLicences lic avsLics = fmap unwrapIds $
|
||||
antijoinAvsLicences lic avsLics = fmap unwrapIds $
|
||||
E.select $ do
|
||||
((_qauli :& _qualUser :& usrAvs) :& excl) <-
|
||||
E.from $ ( E.table @Qualification
|
||||
`E.innerJoin` E.table @QualificationUser
|
||||
`E.on` ( \(quali :& qualUser) ->
|
||||
`E.on` ( \(quali :& qualUser) ->
|
||||
(quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
|
||||
-- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
|
||||
E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence
|
||||
E.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
|
||||
E.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
|
||||
,qualUser E.^. QualificationUserValidUntil)) -- currently valid
|
||||
E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked
|
||||
E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked
|
||||
)
|
||||
`E.innerJoin` E.table @UserAvs
|
||||
`E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
|
||||
@ -204,41 +205,41 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
|
||||
E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join
|
||||
return (usrAvs E.?. UserAvsPersonId, excl)
|
||||
|
||||
unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)
|
||||
unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)
|
||||
unwrapIds = mapBoth (Set.delete noOne) . foldr aux mempty
|
||||
where
|
||||
aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor
|
||||
aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
|
||||
aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)
|
||||
aux _ acc = acc -- should never occur
|
||||
|
||||
((vorfGrant, vorfRevoke), (rollGrant, rollRevoke)) <- runDB $ (,)
|
||||
<$> antijoinAvsLicences AvsLicenceVorfeld vorORrollfeld
|
||||
<*> antijoinAvsLicences AvsLicenceRollfeld rollfeld
|
||||
let setTo0 = vorfRevoke -- ready to use with SET 0
|
||||
let setTo0 = vorfRevoke -- ready to use with SET 0
|
||||
setTo1 = (vorfGrant Set.\\ rollGrant ) `Set.union` (rollRevoke Set.\\ vorfRevoke)
|
||||
setTo2 = (rollGrant Set.\\ vorfRevoke) `Set.intersection` (vorfGrant `Set.union` vorORrollfeld)
|
||||
return (setTo0, setTo1, setTo2)
|
||||
{- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
|
||||
A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
|
||||
{- Cases to consider (AVS_Licence,has_valid_F, has_valid_R) -> (vorfeld@(toset,unset), rollfeld@(toset,unset)) :
|
||||
A (0,0,0) -> ((_,_),(_,_)) : nop; avs_id not returned from queries, no problem
|
||||
B (0,0,1) -> ((_,_),(x,_)) : nop; do nothing -- CHECK since id is returned by roll-query
|
||||
C (0,1,0) -> ((x,_),(_,_)) : set F for id
|
||||
C (0,1,0) -> ((x,_),(_,_)) : set F for id
|
||||
D (0,1,1) -> ((x,_),(x,_)) : set R for id
|
||||
E (1,0,0) -> ((_,x),(_,_)) : set 0 for id
|
||||
F (1,0,1) -> ((_,x),(x,_)) : set 0 for id
|
||||
F (1,0,1) -> ((_,x),(x,_)) : set 0 for id
|
||||
G (1,1,0) -> ((_,_),(_,_)) : nop
|
||||
H (1,1,1) -> ((_,_),(x,_)) : set R for id
|
||||
I (2,0,0) -> ((_,x),(_,x)) : set 0 for id
|
||||
J (2,0,1) -> ((_,x),(_,_)) : set 0 for id
|
||||
K (2,1,0) -> ((_,_),(_,x)) : set F for id
|
||||
J (2,0,1) -> ((_,x),(_,_)) : set 0 for id
|
||||
K (2,1,0) -> ((_,_),(_,x)) : set F for id
|
||||
L (2,1,1) -> ((_,_),(_,_)) : nop
|
||||
|
||||
PROBLEM: B & H in conflict! (Note that nop is automatic except for case B)
|
||||
Results:
|
||||
set to 0: determined by vorfeld-unset -- zuerst
|
||||
set to 0: determined by vorfeld-unset -- zuerst
|
||||
set to 1: vorfeld-set && nicht in rollfeld-set || rollfeld-unset && nicht in vorfeld-unset
|
||||
set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld)
|
||||
set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld)
|
||||
-}
|
||||
|
||||
|
||||
|
||||
-- | Always update AVS Data
|
||||
upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
|
||||
@ -246,7 +247,7 @@ upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard so
|
||||
upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
|
||||
try (runDB $ ldapLookupAndUpsert otherId) >>= \case
|
||||
Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
|
||||
Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now
|
||||
Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now
|
||||
_ -> return Nothing
|
||||
|
||||
|
||||
@ -262,7 +263,7 @@ upsertAvsUserByCard persNo = do
|
||||
case Set.elems adps of
|
||||
[] -> throwM AvsPersonSearchEmpty
|
||||
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
||||
[AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update
|
||||
[AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update
|
||||
-- do
|
||||
-- mbuid <- runDB $ getBy $ UniqueUserAvsId api
|
||||
-- case mbuid of
|
||||
@ -299,9 +300,9 @@ upsertAvsUserById api = do
|
||||
(Nothing, Just AvsDataPerson{..}) -> do -- No LDAP User, but found in AVS; create new user
|
||||
let firmAddress = guessLicenceAddress avsPersonPersonCards
|
||||
mbCompany = firmAddress ^? _Just . _1 . _Just
|
||||
userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
|
||||
userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
|
||||
pinCard = Set.lookupMax avsPersonPersonCards
|
||||
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
|
||||
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
|
||||
fakeIdent = CI.mk $ "AVSID:" <> tshow api
|
||||
fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo
|
||||
newUsr = AdminUserForm
|
||||
@ -323,32 +324,32 @@ upsertAvsUserById api = do
|
||||
, aufIdent = fakeIdent -- use AvsPersonId instead
|
||||
, aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known
|
||||
}
|
||||
mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
|
||||
whenIsJust mbUid $ \uid -> runDB $ do
|
||||
mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
|
||||
whenIsJust mbUid $ \uid -> runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo
|
||||
forM_ avsPersonPersonCards $ -- save all cards for later
|
||||
-- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
|
||||
-- forM_ cs $ -- only save used cards for the postal address update detection
|
||||
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now
|
||||
upsertUserCompany uid mbCompany
|
||||
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now
|
||||
upsertUserCompany uid mbCompany
|
||||
return mbUid
|
||||
|
||||
|
||||
(Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword
|
||||
let firmAddress = guessLicenceAddress avsPersonPersonCards
|
||||
mbCompany = firmAddress ^? _Just . _1 . _Just
|
||||
mbCoFirmAddr= mergeCompanyAddress <$> firmAddress
|
||||
userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr
|
||||
userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr
|
||||
pinCard = Set.lookupMax avsPersonPersonCards
|
||||
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
|
||||
runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
|
||||
runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
oldCards <- selectList [UserAvsCardPersonId ==. api] []
|
||||
let oldAddrs = Set.fromList $ mapMaybe (maybeCompanyAddress . userAvsCardCard . entityVal) oldCards
|
||||
unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before
|
||||
updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
|
||||
whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card
|
||||
unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do
|
||||
unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do
|
||||
let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards
|
||||
updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins]
|
||||
[UserPinPassword =. userPin]
|
||||
@ -362,7 +363,7 @@ upsertAvsUserById api = do
|
||||
}
|
||||
[ UserAvsCardCard =. aCard
|
||||
, UserAvsCardLastSynch =. now
|
||||
]
|
||||
]
|
||||
return $ Just uid
|
||||
|
||||
|
||||
@ -388,3 +389,26 @@ lookupAvsUsers apis = do
|
||||
AvsResponsePerson adps <- throwLeftM . avsQueryPerson $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
|
||||
return $ mergeByPersonId adps acc2
|
||||
|
||||
|
||||
-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date
|
||||
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
|
||||
updateReceivers uid = do
|
||||
(underling :: Entity User, avsUnderling :: Maybe (Entity UserAvs), avsSupers :: [Entity UserAvs]) <- runDB $ (,,)
|
||||
<$> getJustEntity uid
|
||||
<*> getBy (UniqueUserAvsUser uid)
|
||||
<*> (E.select $ do
|
||||
(usrSuper :& usrAvs) <-
|
||||
E.from $ E.table @UserSupervisor
|
||||
`E.innerJoin` E.table @UserAvs
|
||||
`E.on` (\(usrSuper :& userAvs) ->usrSuper E.^. UserSupervisorSupervisor E.==. userAvs E.^. UserAvsUser)
|
||||
E.where_ $ (usrSuper E.^. UserSupervisorUser E.==. E.val uid)
|
||||
E.&&. (usrSuper E.^. UserSupervisorRerouteNotifications)
|
||||
pure usrAvs
|
||||
)
|
||||
let toUpdate = Set.fromList (userAvsPersonId . entityVal <$> mcons avsUnderling avsSupers)
|
||||
forM_ toUpdate (void . upsertAvsUserById) -- update postaddress from AVS
|
||||
let receiverIDs :: [UserId] = userAvsUser . entityVal <$> avsSupers
|
||||
receivers <- runDB (catMaybes <$> mapM getEntity receiverIDs)
|
||||
return $ if null receivers
|
||||
then (underling, pure underling, True)
|
||||
else (underling, receivers, underling `elem` receivers)
|
||||
@ -47,14 +47,13 @@ import qualified Data.Text as Text
|
||||
|
||||
import Jobs.Types(Job, JobChildren)
|
||||
|
||||
|
||||
abbrvName :: User -> Text
|
||||
abbrvName User{userDisplayName, userFirstName, userSurname} =
|
||||
if | (lastDisplayName : tsrif) <- reverse nameParts
|
||||
abbrvName User{userDisplayName, userFirstName, userSurname} =
|
||||
if | (lastDisplayName : tsrif) <- reverse nameParts
|
||||
-> assemble $ reverse $ lastDisplayName : abbreviate tsrif
|
||||
| otherwise
|
||||
-> assemble $ abbreviate (Text.words userFirstName) <> [userSurname]
|
||||
where
|
||||
where
|
||||
nameParts = Text.words userDisplayName
|
||||
abbreviate = fmap (Text.take 1)
|
||||
assemble = Text.intercalate "."
|
||||
@ -72,11 +71,11 @@ userPrefersEmail = not . userPrefersLetter
|
||||
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
|
||||
getPostalPreferenceAndAddress usr@User{..} =
|
||||
(((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa)
|
||||
where
|
||||
where
|
||||
orgEmail = CI.original userEmail
|
||||
emailImpossible = not ('@' `textElem` orgEmail && '.' `textElem` orgEmail)
|
||||
postPossible = isJust pa
|
||||
pa = getPostalAddress usr
|
||||
pa = getPostalAddress usr
|
||||
|
||||
getPostalAddress :: User -> Maybe [Text]
|
||||
getPostalAddress User{..}
|
||||
@ -85,22 +84,23 @@ getPostalAddress User{..}
|
||||
| Just abt <- userCompanyDepartment
|
||||
= Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
|
||||
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
|
||||
| otherwise
|
||||
| otherwise
|
||||
= Nothing
|
||||
|
||||
-- | Return Entity User and all Supervisors with rerouteNotifications as well as
|
||||
-- | DEPRECATED, use Handler.Utis.Avs. updateReceivers instead
|
||||
-- Return Entity User and all Supervisors with rerouteNotifications as well as
|
||||
-- a boolean indicating if the user is own supervisor with rerouteNotifications
|
||||
getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)
|
||||
getReceivers uid = do
|
||||
underling <- getJustEntity uid
|
||||
superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
|
||||
let superIds = userSupervisorSupervisor . entityVal <$> superVs
|
||||
if null superIds
|
||||
if null superIds
|
||||
then return (underling, [underling], True)
|
||||
else do
|
||||
else do
|
||||
supers <- selectList [UserId <-. superIds] []
|
||||
if null supers then return (underling, [underling], True)
|
||||
else
|
||||
else
|
||||
return (underling, supers, uid `elem` (entityKey <$> supers))
|
||||
|
||||
|
||||
@ -152,7 +152,7 @@ matchesName (repack -> haystack) (repack -> needle)
|
||||
|
||||
guessUser :: PredDNF GuessUserInfo -- ^ guessing criteria
|
||||
-> Maybe Int64 -- ^ Should the query be limited to a maximum number of results?
|
||||
-> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User))) -- ^ Just (Left _) in case of multiple results,
|
||||
-> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User))) -- ^ Just (Left _) in case of multiple results,
|
||||
-- Just (Right _) in case of single result, and
|
||||
-- Nothing in case of no result
|
||||
guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) mQueryLimit = $cachedHereBinary criteria $ go False
|
||||
@ -161,7 +161,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
||||
asWords = filter (not . Text.null) . Text.words . Text.strip
|
||||
|
||||
containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
|
||||
|
||||
|
||||
toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of
|
||||
GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
|
||||
GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN')
|
||||
@ -184,7 +184,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
||||
$ criteria ^.. folded)
|
||||
|
||||
closeness :: Entity User -> Entity User -> Ordering
|
||||
closeness ul ur = maximum $ impureNonNull $ criteria <&> \term ->
|
||||
closeness ul ur = maximum $ impureNonNull $ criteria <&> \term ->
|
||||
let
|
||||
matches userField name = _entityVal . userField . to (`matchesName` name)
|
||||
comp True userField guess = (term ^.. folded . _PLVariable . guess) <&> \name ->
|
||||
@ -203,7 +203,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
||||
]
|
||||
, b <- [True,False]
|
||||
]
|
||||
|
||||
|
||||
-- Assuming the input list is sorted in descending order by closeness:
|
||||
takeClosest [] = []
|
||||
takeClosest [x] = [x]
|
||||
@ -235,7 +235,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
||||
convertLdapResults [] = Nothing
|
||||
convertLdapResults [x] = Just $ Right x
|
||||
convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs
|
||||
|
||||
|
||||
if
|
||||
| [x] <- users'
|
||||
, Just True == matchesMatriculation x || didLdap
|
||||
@ -282,9 +282,9 @@ assimilateUser :: UserId -- ^ @newUserId@
|
||||
-- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @newUserId@
|
||||
--
|
||||
-- Fatal errors are thrown, non-fatal warnings are returned
|
||||
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.insertSelectWithConflict
|
||||
UniqueCourseFavourite
|
||||
UniqueCourseFavourite
|
||||
(E.from $ \courseFavourite -> do
|
||||
E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
|
||||
return $ CourseFavourite
|
||||
@ -414,7 +414,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
)
|
||||
(\_current _excluded -> [])
|
||||
deleteWhere [ SubmissionUserUser ==. oldUserId ]
|
||||
|
||||
|
||||
do
|
||||
collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
|
||||
E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
|
||||
@ -659,7 +659,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
)
|
||||
(\current excluded -> [ ExamPartResultLastChanged E.=. E.max (current E.^. ExamPartResultLastChanged) (excluded E.^. ExamPartResultLastChanged) ])
|
||||
deleteWhere [ ExamPartResultUser ==. oldUserId ]
|
||||
|
||||
|
||||
do
|
||||
collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
|
||||
E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
|
||||
@ -681,7 +681,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
)
|
||||
(\current excluded -> [ ExamBonusLastChanged E.=. E.max (current E.^. ExamBonusLastChanged) (excluded E.^. ExamBonusLastChanged) ])
|
||||
deleteWhere [ ExamBonusUser ==. oldUserId ]
|
||||
|
||||
|
||||
let getExamResults = selectSource [ ExamResultUser ==. oldUserId ] []
|
||||
upsertExamResult oldEREnt@(Entity oldERId oldER) = do
|
||||
newER' <- getBy $ UniqueExamResult (examResultExam oldER) newUserId
|
||||
@ -847,19 +847,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
delete oldSFId
|
||||
in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures
|
||||
|
||||
-- Qualifications and ongoing LMS
|
||||
-- Qualifications and ongoing LMS
|
||||
-- LmsUser: insertSelectWithConflict impossible due to 2 simultaneous uniqueness constraints; UniqueLmsIdent requires proper update, prohibits insert and then delete
|
||||
-- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser
|
||||
-- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser
|
||||
oldLms <- selectList [ LmsUserUser ==. oldUserId ] [ Asc LmsUserQualification ]
|
||||
newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ]
|
||||
let projQ = lmsUserQualification . entityVal
|
||||
oldQs = Set.fromList (projQ <$> oldLms)
|
||||
newQs = Set.fromList (projQ <$> newLms)
|
||||
qConflicts = oldQs `Set.intersection` newQs
|
||||
qResolvable = Set.fromList [ lmsUserQualification | Entity _ LmsUser{..} <- oldLms, isJust lmsUserEnded, lmsUserQualification `Set.member` qConflicts ]
|
||||
qProblems = qConflicts `Set.difference` qResolvable
|
||||
qResolvable = Set.fromList [ lmsUserQualification | Entity _ LmsUser{..} <- oldLms, isJust lmsUserEnded, lmsUserQualification `Set.member` qConflicts ]
|
||||
qProblems = qConflicts `Set.difference` qResolvable
|
||||
unless (Set.null qProblems) $ tellError $ UserAssimilateConflictingLmsQualifications qProblems
|
||||
unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
|
||||
unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
|
||||
updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
|
||||
updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
|
||||
E.insertSelectWithConflict
|
||||
@ -874,19 +874,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
|
||||
E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
|
||||
)
|
||||
(\current excluded ->
|
||||
(\current excluded ->
|
||||
[ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil
|
||||
, QualificationUserLastRefresh E.=. combineWith current excluded E.greatest QualificationUserLastRefresh
|
||||
, QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld
|
||||
, QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
|
||||
]
|
||||
]
|
||||
)
|
||||
deleteWhere [ QualificationUserUser ==. oldUserId ]
|
||||
|
||||
-- Supervision is fully merged
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserSupervisor
|
||||
(E.from $ \userSupervisor -> do
|
||||
(E.from $ \userSupervisor -> do
|
||||
E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
|
||||
return $ UserSupervisor
|
||||
E.<# E.val newUserId
|
||||
@ -894,11 +894,11 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
|
||||
)
|
||||
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
|
||||
deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
|
||||
deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
|
||||
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserSupervisor
|
||||
(E.from $ \userSupervisor -> do
|
||||
(E.from $ \userSupervisor -> do
|
||||
E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
|
||||
return $ UserSupervisor
|
||||
E.<# (userSupervisor E.^. UserSupervisorSupervisor)
|
||||
@ -906,14 +906,14 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
|
||||
)
|
||||
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
|
||||
deleteWhere [ UserSupervisorUser ==. oldUserId]
|
||||
deleteWhere [ UserSupervisorUser ==. oldUserId]
|
||||
|
||||
-- Companies, in conflict, keep the newUser-Company as is
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserCompany
|
||||
(E.from $ \userCompany -> do
|
||||
(E.from $ \userCompany -> do
|
||||
E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
|
||||
return $ UserCompany
|
||||
return $ UserCompany
|
||||
E.<# E.val newUserId
|
||||
E.<&> (userCompany E.^. UserCompanyCompany)
|
||||
E.<&> (userCompany E.^. UserCompanySupervisor)
|
||||
@ -949,4 +949,4 @@ combineWith :: (PersistEntity val, PersistField typ1) =>
|
||||
-> (E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ2))
|
||||
-> EntityField val typ1
|
||||
-> E.SqlExpr (E.Value typ2)
|
||||
combineWith x y f pj = f (x E.^. pj) (y E.^. pj)
|
||||
combineWith x y f pj = f (x E.^. pj) (y E.^. pj)
|
||||
|
||||
@ -413,7 +413,7 @@ instance MDLetter LetterRenewQualificationF where
|
||||
|
||||
sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool
|
||||
sendEmailOrLetter recipient letter = do
|
||||
(underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers recipient
|
||||
(underling, receivers, undercopy) <- runDB $ getReceivers recipient
|
||||
let tmpl = getTemplate $ pure letter
|
||||
pjid = getPJId letter
|
||||
-- Below are only needed if sent by email
|
||||
|
||||
Loading…
Reference in New Issue
Block a user