diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index f07dc6003..aa91006f3 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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) \ No newline at end of file diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 07533158f..14267e559 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -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) \ No newline at end of file +combineWith x y f pj = f (x E.^. pj) (y E.^. pj) diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index e6f4a3b1b..58b0897f9 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -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