880 lines
44 KiB
Haskell
880 lines
44 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Utils.Users
|
|
( computeUserAuthenticationDigest
|
|
, Digest, SHA3_256
|
|
, constEq
|
|
, NameMatchQuality(..)
|
|
, matchesName
|
|
, GuessUserInfo(..)
|
|
, guessUser
|
|
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
|
|
, assimilateUser
|
|
, userPrefersEmail, userPrefersLetter
|
|
, getPostalAddress, getPostalPreferenceAndAddress
|
|
, abbrvName
|
|
, getReceivers
|
|
) where
|
|
|
|
import Import
|
|
import Auth.LDAP (campusUserMatr')
|
|
import Foundation.Yesod.Auth (upsertCampusUser)
|
|
|
|
import Crypto.Hash (hashlazy)
|
|
|
|
import Data.ByteArray (constEq)
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.List.NonEmpty as NonEmpty (fromList)
|
|
|
|
import qualified Data.Aeson as JSON
|
|
import qualified Data.Aeson.Types as JSON
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.List as List
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import qualified Data.MultiSet as MultiSet
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
|
|
import Jobs.Types(Job, JobChildren)
|
|
|
|
|
|
abbrvName :: User -> Text
|
|
abbrvName User{userDisplayName, userFirstName, userSurname} =
|
|
if | (lastDisplayName : tsrif) <- reverse nameParts
|
|
-> assemble $ reverse $ lastDisplayName : abbreviate tsrif
|
|
| otherwise
|
|
-> assemble $ abbreviate (Text.words userFirstName) <> [userSurname]
|
|
where
|
|
nameParts = Text.words userDisplayName
|
|
abbreviate = fmap (Text.take 1)
|
|
assemble = Text.intercalate "."
|
|
|
|
|
|
-- deprecated, used getPostalAddressIfPreferred
|
|
userPrefersLetter :: User -> Bool
|
|
userPrefersLetter = fst . getPostalPreferenceAndAddress
|
|
|
|
-- deprecated, used getPostalAddressIfPreferred
|
|
userPrefersEmail :: User -> Bool
|
|
userPrefersEmail = not . userPrefersLetter
|
|
|
|
-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
|
|
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
|
|
getPostalPreferenceAndAddress usr@User{..} =
|
|
(((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa)
|
|
where
|
|
orgEmail = CI.original userEmail
|
|
emailImpossible = not ('@' `textElem` orgEmail && '.' `textElem` orgEmail)
|
|
postPossible = isJust pa
|
|
pa = getPostalAddress usr
|
|
|
|
getPostalAddress :: User -> Maybe [Text]
|
|
getPostalAddress User{..}
|
|
| Just pa <- userPostAddress
|
|
= Just $ userDisplayName : html2textlines pa
|
|
| Just abt <- userCompanyDepartment
|
|
= Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
|
|
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
|
|
| otherwise
|
|
= Nothing
|
|
|
|
-- | 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
|
|
then return (underling, [underling], True)
|
|
else do
|
|
supers <- selectList [UserId <-. superIds] []
|
|
if null supers then return (underling, [underling], True)
|
|
else
|
|
return (underling, supers, uid `elem` (entityKey <$> supers))
|
|
|
|
|
|
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
|
|
computeUserAuthenticationDigest = hashlazy . JSON.encode
|
|
|
|
|
|
data GuessUserInfo
|
|
= GuessUserMatrikelnummer
|
|
{ guessUserMatrikelnummer :: UserMatriculation }
|
|
| GuessUserEduPersonPrincipalName
|
|
{ guessUserEduPersonPrincipalName :: UserEduPersonPrincipalName }
|
|
| GuessUserDisplayName
|
|
{ guessUserDisplayName :: UserDisplayName }
|
|
| GuessUserSurname
|
|
{ guessUserSurname :: UserSurname }
|
|
| GuessUserFirstName
|
|
{ guessUserFirstName :: UserFirstName }
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
instance Binary GuessUserInfo
|
|
|
|
makeLenses_ ''GuessUserInfo
|
|
|
|
data NameMatchQuality
|
|
= NameMatchSuffix
|
|
| NameMatchPrefix
|
|
| NameMatchPermutation
|
|
| NameMatchEqual
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
matchesName :: Textual t
|
|
=> t -- ^ haystack
|
|
-> t -- ^ needle
|
|
-> Maybe NameMatchQuality
|
|
matchesName (repack -> haystack) (repack -> needle)
|
|
= fmap (view _1) . Map.lookupMax $ Map.filter id tests
|
|
where
|
|
asWords :: Text -> [CI Text]
|
|
asWords = map CI.mk . filter (not . Text.null) . Text.words . Text.strip
|
|
|
|
tests :: Map NameMatchQuality Bool
|
|
tests = mconcat
|
|
[ singletonMap NameMatchEqual $ asWords needle == asWords haystack
|
|
, singletonMap NameMatchPrefix $ asWords needle `isPrefixOf` asWords haystack
|
|
, singletonMap NameMatchSuffix $ asWords needle `isSuffixOf` asWords haystack
|
|
, singletonMap NameMatchPermutation $ ((==) `on` MultiSet.fromList) (asWords needle) (asWords haystack)
|
|
]
|
|
|
|
|
|
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,
|
|
-- 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
|
|
where
|
|
asWords :: Text -> [Text]
|
|
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')
|
|
GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName'
|
|
GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname'
|
|
GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName'
|
|
|
|
go didLdap = do
|
|
let retrieveUsers = E.select . E.from $ \user -> do
|
|
E.where_ . E.or $ map (E.and . map (toSql user)) criteria
|
|
when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
|
|
return user
|
|
users <- retrieveUsers
|
|
let users' = sortBy (flip closeness) users
|
|
|
|
matchesMatriculation :: Entity User -> Maybe Bool
|
|
matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr ->
|
|
any (\p -> all ((== userMatr) . Just) (p ^.. folded . _PLVariable . _guessUserMatrikelnummer)
|
|
&& all ((/= userMatr) . Just) (p ^.. folded . _PLNegated . _guessUserMatrikelnummer))
|
|
$ criteria ^.. folded)
|
|
|
|
closeness :: Entity User -> Entity User -> Ordering
|
|
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 ->
|
|
compare ( ul ^. userField `matches` name)
|
|
( ur ^. userField `matches` name)
|
|
comp False userField guess = (term ^.. folded . _PLNegated . guess) <&> \name ->
|
|
compare (Down $ ul ^. userField `matches` name)
|
|
(Down $ ur ^. userField `matches` name)
|
|
in mconcat $ concat $
|
|
[ pure $ compare (Down $ matchesMatriculation ul) (Down $ matchesMatriculation ur)
|
|
] <>
|
|
[ comp b userField guess
|
|
| (userField,guess) <- [(_userSurname , _guessUserSurname)
|
|
,(_userFirstName , _guessUserFirstName)
|
|
,(_userDisplayName, _guessUserDisplayName)
|
|
]
|
|
, b <- [True,False]
|
|
]
|
|
|
|
-- Assuming the input list is sorted in descending order by closeness:
|
|
takeClosest [] = []
|
|
takeClosest [x] = [x]
|
|
takeClosest (x:x':xs)
|
|
| EQ <- x `closeness` x' = x : takeClosest (x':xs)
|
|
| otherwise = [x]
|
|
|
|
doLdap userMatr = do
|
|
ldapPool' <- getsYesod $ view _appLdapPool
|
|
fmap join . for ldapPool' $ \ldapPool -> do
|
|
ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
|
|
for ldapData $ upsertCampusUser UpsertCampusUserGuessUser
|
|
|
|
let
|
|
getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
|
|
getTermMatr = getTermMatrAux Nothing where
|
|
getTermMatrAux acc [] = acc
|
|
getTermMatrAux acc (PLVariable (GuessUserMatrikelnummer matr):xs)
|
|
| Just matr' <- acc, matr == matr' = getTermMatrAux acc xs
|
|
| Nothing <- acc = getTermMatrAux (Just matr) xs
|
|
| otherwise = Nothing
|
|
getTermMatrAux acc (PLNegated (GuessUserMatrikelnummer matr):xs)
|
|
| Just matr' <- acc, matr /= matr' = getTermMatrAux acc xs
|
|
| Nothing <- acc = getTermMatrAux acc xs
|
|
| otherwise = Nothing
|
|
getTermMatrAux acc (_:xs) = getTermMatrAux acc xs
|
|
|
|
convertLdapResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
|
|
convertLdapResults [] = Nothing
|
|
convertLdapResults [x] = Just $ Right x
|
|
convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs
|
|
|
|
if
|
|
| [x] <- users'
|
|
, Just True == matchesMatriculation x || didLdap
|
|
-> return $ Just $ Right x
|
|
| x : x' : _ <- users'
|
|
, Just True == matchesMatriculation x || didLdap
|
|
, GT <- x `closeness` x'
|
|
-> return $ Just $ Right x
|
|
| xs@(x:_:_) <- takeClosest users'
|
|
, Just True == matchesMatriculation x || didLdap
|
|
-> return $ Just $ Left $ NonEmpty.fromList xs
|
|
| not didLdap
|
|
, userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
|
|
-> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
|
|
| otherwise
|
|
-> return Nothing
|
|
|
|
|
|
data UserAssimilateException = UserAssimilateException
|
|
{ userAssimilateOldUser, userAssimilateNewUser :: UserId
|
|
, userAssimilateException :: UserAssimilateExceptionReason
|
|
} deriving (Eq, Ord, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
data UserAssimilateExceptionReason
|
|
= UserAssimilateExternalExamResultDifferentResult (Entity ExternalExamResult) (Entity ExternalExamResult)
|
|
| UserAssimilateSubmissionGroupUserMultiple (Entity SubmissionGroupUser) (Entity SubmissionGroupUser)
|
|
| UserAssimilateExamRegistrationDifferentOccurrence (Entity ExamRegistration) (Entity ExamRegistration)
|
|
| UserAssimilateExamPartResultDifferentResult (Entity ExamPartResult) (Entity ExamPartResult)
|
|
| UserAssimilateExamBonusDifferentBonus (Entity ExamBonus) (Entity ExamBonus)
|
|
| UserAssimilateExamResultDifferentResult (Entity ExamResult) (Entity ExamResult)
|
|
| UserAssimilatePersonalisedSheetFileDifferentContent (Entity PersonalisedSheetFile) (Entity PersonalisedSheetFile)
|
|
| UserAssimilateTutorialParticipantCollidingRegGroups (Entity TutorialParticipant) (Entity TutorialParticipant)
|
|
| UserAssimilateCouldNotDetermineUserIdents
|
|
| UserAssimilateConflictingLmsQualifications (Set.Set QualificationId)
|
|
deriving (Eq, Ord, Show, Generic, Typeable)
|
|
|
|
assimilateUser :: UserId -- ^ @newUserId@
|
|
-> UserId -- ^ @oldUserId@
|
|
-> DB (Set UserAssimilateException) -- ^ Warnings
|
|
-- ^ 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
|
|
E.insertSelectWithConflict
|
|
UniqueCourseFavourite
|
|
(E.from $ \courseFavourite -> do
|
|
E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
|
|
return $ CourseFavourite
|
|
E.<# E.val newUserId
|
|
E.<&> (courseFavourite E.^. CourseFavouriteCourse)
|
|
E.<&> (courseFavourite E.^. CourseFavouriteReason)
|
|
E.<&> (courseFavourite E.^. CourseFavouriteLastVisit)
|
|
)
|
|
(\current excluded -> [ CourseFavouriteLastVisit E.=. E.max (current E.^. CourseFavouriteLastVisit) (excluded E.^. CourseFavouriteLastVisit) ])
|
|
deleteWhere [ CourseFavouriteUser ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueCourseNoFavourite
|
|
(E.from $ \courseNoFavourite -> do
|
|
E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId
|
|
return $ CourseNoFavourite
|
|
E.<# E.val newUserId
|
|
E.<&> (courseNoFavourite E.^. CourseNoFavouriteCourse)
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ CourseNoFavouriteUser ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueExamOfficeField
|
|
(E.from $ \examOfficeField -> do
|
|
E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId
|
|
return $ ExamOfficeField
|
|
E.<# E.val newUserId
|
|
E.<&> (examOfficeField E.^. ExamOfficeFieldField)
|
|
E.<&> (examOfficeField E.^. ExamOfficeFieldForced)
|
|
)
|
|
(\current excluded -> [ ExamOfficeFieldForced E.=. (current E.^. ExamOfficeFieldForced E.||. excluded E.^. ExamOfficeFieldForced) ])
|
|
deleteWhere [ ExamOfficeFieldOffice ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueExamOfficeUser
|
|
(E.from $ \examOfficeUser -> do
|
|
E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId
|
|
return $ ExamOfficeUser
|
|
E.<# E.val newUserId
|
|
E.<&> (examOfficeUser E.^. ExamOfficeUserUser)
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ ExamOfficeUserOffice ==. oldUserId ]
|
|
E.insertSelectWithConflict
|
|
UniqueExamOfficeUser
|
|
(E.from $ \examOfficeUser -> do
|
|
E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId
|
|
return $ ExamOfficeUser
|
|
E.<# (examOfficeUser E.^. ExamOfficeUserOffice)
|
|
E.<&> E.val newUserId
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ ExamOfficeUserUser ==. oldUserId ]
|
|
|
|
E.insertSelect . E.from $ \examOfficeResultSynced -> do
|
|
E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId
|
|
return $ ExamOfficeResultSynced
|
|
E.<# (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool)
|
|
E.<&> E.val newUserId
|
|
E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedResult)
|
|
E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime)
|
|
deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ]
|
|
|
|
E.insertSelect . E.from $ \examOfficeExternalResultSynced -> do
|
|
E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId
|
|
return $ ExamOfficeExternalResultSynced
|
|
E.<# (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool)
|
|
E.<&> E.val newUserId
|
|
E.<&> (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedResult)
|
|
E.<&> (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedTime)
|
|
deleteWhere [ ExamOfficeExternalResultSyncedOffice ==. oldUserId ]
|
|
|
|
let getExternalExamResults = selectSource [ ExternalExamResultUser ==. oldUserId ] []
|
|
upsertExternalExamResult oldEEREnt@(Entity oldEERId oldEER) = do
|
|
newEER' <- getBy $ UniqueExternalExamResult (externalExamResultExam oldEER) newUserId
|
|
newEERId <- case newEER' of
|
|
Just newEEREnt@(Entity _ newEER)
|
|
| ((/=) `on` externalExamResultResult) newEER oldEER
|
|
|| ((/=) `on` externalExamResultTime) newEER oldEER
|
|
-> tellError $ UserAssimilateExternalExamResultDifferentResult oldEEREnt newEEREnt
|
|
Just (Entity newEERId newEER) -> newEERId <$ update newEERId
|
|
[ ExternalExamResultLastChanged =. (max `on` externalExamResultLastChanged) oldEER newEER
|
|
]
|
|
Nothing -> insert oldEER
|
|
{ externalExamResultUser = newUserId
|
|
}
|
|
updateWhere [ ExamOfficeExternalResultSyncedResult ==. oldEERId ] [ ExamOfficeExternalResultSyncedResult =. newEERId ]
|
|
delete oldEERId
|
|
in runConduit $ getExternalExamResults .| C.mapM_ upsertExternalExamResult
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueExternalExamStaff
|
|
(E.from $ \externalExamStaff -> do
|
|
E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId
|
|
return $ ExternalExamStaff
|
|
E.<# E.val newUserId
|
|
E.<&> (externalExamStaff E.^. ExternalExamStaffExam)
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ ExternalExamStaffUser ==. oldUserId ]
|
|
|
|
updateWhere [ SubmissionRatingBy ==. Just oldUserId ] [ SubmissionRatingBy =. Just newUserId ]
|
|
|
|
updateWhere [ SubmissionEditUser ==. Just oldUserId ] [ SubmissionEditUser =. Just newUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueSubmissionUser
|
|
(E.from $ \submissionUser -> do
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId
|
|
return $ SubmissionUser
|
|
E.<# E.val newUserId
|
|
E.<&> (submissionUser E.^. SubmissionUserSubmission)
|
|
)
|
|
(\_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
|
|
E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
|
|
E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId
|
|
E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId
|
|
E.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup
|
|
E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse
|
|
return (submissionGroupUserA, submissionGroupUserB)
|
|
forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) ->
|
|
tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB
|
|
E.insertSelectWithConflict
|
|
UniqueSubmissionGroupUser
|
|
(E.from $ \submissionGroupUser -> do
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId
|
|
return $ SubmissionGroupUser
|
|
E.<# (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup)
|
|
E.<&> E.val newUserId
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ SubmissionGroupUserUser ==. oldUserId ]
|
|
|
|
updateWhere [ TransactionLogInitiator ==. Just oldUserId ] [ TransactionLogInitiator =. Just newUserId ]
|
|
-- We're not updating info; doing that would probably be too slow
|
|
-- Just check for `TransactionUserAssimilated` entries and correct manually
|
|
|
|
updateWhere [ CourseEditUser ==. oldUserId ] [ CourseEditUser =. newUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueLecturer
|
|
(E.from $ \lecturer -> do
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId
|
|
return $ Lecturer
|
|
E.<# E.val newUserId
|
|
E.<&> (lecturer E.^. LecturerCourse)
|
|
E.<&> (lecturer E.^. LecturerType)
|
|
)
|
|
(\_current excluded -> [ LecturerType E.=. excluded E.^. LecturerType ])
|
|
deleteWhere [ LecturerUser ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueParticipant
|
|
(E.from $ \courseParticipant -> do
|
|
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId
|
|
return $ CourseParticipant
|
|
E.<# (courseParticipant E.^. CourseParticipantCourse)
|
|
E.<&> E.val newUserId
|
|
E.<&> (courseParticipant E.^. CourseParticipantRegistration)
|
|
E.<&> (courseParticipant E.^. CourseParticipantState)
|
|
)
|
|
(\current excluded ->
|
|
[ CourseParticipantState E.=. E.exprLift min (current E.^. CourseParticipantState) (excluded E.^. CourseParticipantState)
|
|
, CourseParticipantRegistration E.=. E.max (current E.^. CourseParticipantRegistration) (excluded E.^. CourseParticipantRegistration)
|
|
]
|
|
)
|
|
deleteWhere [ CourseParticipantUser ==. oldUserId ]
|
|
|
|
let getCourseUserNotes = selectSource [ CourseUserNoteUser ==. oldUserId ] []
|
|
upsertCourseUserNote (Entity oldCUNId oldCUN) = do
|
|
collision <- getBy $ UniqueCourseUserNote newUserId (courseUserNoteCourse oldCUN)
|
|
newCUNId <- case collision of
|
|
Nothing -> oldCUNId <$ update oldCUNId [ CourseUserNoteUser =. newUserId ]
|
|
Just (Entity newCUNId newCUN) -> newCUNId <$ update newCUNId [ CourseUserNoteNote =. ((<>) `on` courseUserNoteNote) oldCUN newCUN ]
|
|
when (newCUNId /= oldCUNId) $
|
|
updateWhere [CourseUserNoteEditNote ==. oldCUNId] [CourseUserNoteEditNote =. newCUNId]
|
|
delete oldCUNId
|
|
in runConduit $ getCourseUserNotes .| C.mapM_ upsertCourseUserNote
|
|
|
|
updateWhere [ CourseUserNoteEditUser ==. oldUserId ] [ CourseUserNoteEditUser =. newUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueCourseUserExamOfficeOptOut
|
|
(E.from $ \examOfficeOptOut -> do
|
|
E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId
|
|
return $ CourseUserExamOfficeOptOut
|
|
E.<# (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse)
|
|
E.<&> E.val newUserId
|
|
E.<&> (examOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool)
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ CourseUserExamOfficeOptOutUser ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueUserFunction
|
|
(E.from $ \userFunction -> do
|
|
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId
|
|
return $ UserFunction
|
|
E.<# E.val newUserId
|
|
E.<&> (userFunction E.^. UserFunctionSchool)
|
|
E.<&> (userFunction E.^. UserFunctionFunction)
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ UserFunctionUser ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueUserSystemFunction
|
|
(E.from $ \userSystemFunction -> do
|
|
E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId
|
|
return $ UserSystemFunction
|
|
E.<# E.val newUserId
|
|
E.<&> (userSystemFunction E.^. UserSystemFunctionFunction)
|
|
E.<&> (userSystemFunction E.^. UserSystemFunctionManual)
|
|
E.<&> (userSystemFunction E.^. UserSystemFunctionIsOptOut)
|
|
)
|
|
(\current excluded -> [ UserSystemFunctionManual E.=. (current E.^. UserSystemFunctionManual E.||. excluded E.^. UserSystemFunctionManual), UserSystemFunctionIsOptOut E.=. (current E.^. UserSystemFunctionIsOptOut E.&&. excluded E.^. UserSystemFunctionIsOptOut) ])
|
|
deleteWhere [ UserSystemFunctionUser ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueUserExamOffice
|
|
(E.from $ \userExamOffice -> do
|
|
E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId
|
|
return $ UserExamOffice
|
|
E.<# E.val newUserId
|
|
E.<&> (userExamOffice E.^. UserExamOfficeField)
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ UserExamOfficeUser ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueUserSchool
|
|
(E.from $ \userSchool -> do
|
|
E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId
|
|
return $ UserSchool
|
|
E.<# E.val newUserId
|
|
E.<&> (userSchool E.^. UserSchoolSchool)
|
|
E.<&> (userSchool E.^. UserSchoolIsOptOut)
|
|
)
|
|
(\current excluded -> [ UserSchoolIsOptOut E.=. (current E.^. UserSchoolIsOptOut E.&&. excluded E.^. UserSchoolIsOptOut) ])
|
|
deleteWhere [ UserSchoolUser ==. oldUserId ]
|
|
|
|
updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ]
|
|
E.insertSelectWithConflict
|
|
UniqueUserGroupMember
|
|
(E.from $ \userGroupMember -> do
|
|
E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId
|
|
return $ UserGroupMember
|
|
E.<# (userGroupMember E.^. UserGroupMemberGroup)
|
|
E.<&> E.val newUserId
|
|
E.<&> (userGroupMember E.^. UserGroupMemberPrimary)
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ UserGroupMemberUser ==. oldUserId ]
|
|
|
|
do
|
|
collisions <- E.select . E.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
|
|
E.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam
|
|
E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId
|
|
E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId
|
|
E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence
|
|
E.&&. E.isJust (examRegistrationA E.^. ExamRegistrationOccurrence)
|
|
E.&&. E.isJust (examRegistrationB E.^. ExamRegistrationOccurrence)
|
|
return (examRegistrationA, examRegistrationB)
|
|
forM_ collisions $ \(oldExamRegistration, newExamRegistration)
|
|
-> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration
|
|
E.insertSelectWithConflict
|
|
UniqueExamRegistration
|
|
(E.from $ \examRegistration -> do
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId
|
|
return $ ExamRegistration
|
|
E.<# (examRegistration E.^. ExamRegistrationExam)
|
|
E.<&> E.val newUserId
|
|
E.<&> (examRegistration E.^. ExamRegistrationOccurrence)
|
|
E.<&> (examRegistration E.^. ExamRegistrationTime)
|
|
)
|
|
(\current excluded -> [ ExamRegistrationOccurrence E.=. E.alt (current E.^. ExamRegistrationOccurrence) (excluded E.^. ExamRegistrationOccurrence), ExamRegistrationTime E.=. E.min (current E.^. ExamRegistrationTime) (excluded E.^. ExamRegistrationTime) ])
|
|
deleteWhere [ ExamRegistrationUser ==. oldUserId ]
|
|
|
|
do
|
|
collision <- E.selectMaybe . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
|
|
E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
|
|
E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId
|
|
E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId
|
|
E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult
|
|
return (examPartResultA, examPartResultB)
|
|
whenIsJust collision $ \(oldExamPartResult, newExamPartResult)
|
|
-> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult
|
|
E.insertSelectWithConflict
|
|
UniqueExamPartResult
|
|
(E.from $ \examPartResult -> do
|
|
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId
|
|
return $ ExamPartResult
|
|
E.<# (examPartResult E.^. ExamPartResultExamPart)
|
|
E.<&> E.val newUserId
|
|
E.<&> (examPartResult E.^. ExamPartResultResult)
|
|
E.<&> (examPartResult E.^. ExamPartResultLastChanged)
|
|
)
|
|
(\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
|
|
E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId
|
|
E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId
|
|
E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus
|
|
return (examBonusA, examBonusB)
|
|
whenIsJust collision $ \(oldExamBonus, newExamBonus)
|
|
-> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus
|
|
E.insertSelectWithConflict
|
|
UniqueExamBonus
|
|
(E.from $ \examBonus -> do
|
|
E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId
|
|
return $ ExamBonus
|
|
E.<# (examBonus E.^. ExamBonusExam)
|
|
E.<&> E.val newUserId
|
|
E.<&> (examBonus E.^. ExamBonusBonus)
|
|
E.<&> (examBonus E.^. ExamBonusLastChanged)
|
|
)
|
|
(\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
|
|
newERId <- case newER' of
|
|
Just newEREnt@(Entity _ newER)
|
|
| ((/=) `on` examResultResult) newER oldER
|
|
-> tellError $ UserAssimilateExamResultDifferentResult oldEREnt newEREnt
|
|
Just (Entity newERId newER) -> newERId <$ update newERId
|
|
[ ExamResultLastChanged =. (max `on` examResultLastChanged) oldER newER
|
|
]
|
|
Nothing -> insert oldER
|
|
{ examResultUser = newUserId
|
|
}
|
|
updateWhere [ ExamOfficeResultSyncedResult ==. oldERId ] [ ExamOfficeResultSyncedResult =. newERId ]
|
|
delete oldERId
|
|
in runConduit $ getExamResults .| C.mapM_ upsertExamResult
|
|
|
|
let getExamCorrectors = selectSource [ ExamCorrectorUser ==. oldUserId ] []
|
|
upsertExamCorrector (Entity oldECId examCorrector) = do
|
|
Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } []
|
|
E.insertSelectWithConflict
|
|
UniqueExamPartCorrector
|
|
(E.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
|
|
E.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector
|
|
E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId
|
|
E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector)
|
|
return $ ExamPartCorrector
|
|
E.<# (examPartCorrector E.^. ExamPartCorrectorPart)
|
|
E.<&> E.val newECId
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ ExamPartCorrectorCorrector ==. oldECId ]
|
|
delete oldECId
|
|
in runConduit $ getExamCorrectors .| C.mapM_ upsertExamCorrector
|
|
|
|
let getQueuedJobs = selectSource [] []
|
|
updateQueuedJob (Entity jId QueuedJob{..}) = maybeT_ $ do
|
|
(content' :: Job) <- hoistMaybe $ JSON.parseMaybe parseJSON queuedJobContent
|
|
let uContent' = set (typesUsing @JobChildren . filtered (== oldUserId)) newUserId content'
|
|
guard $ uContent' /= content'
|
|
lift $ update jId [ QueuedJobContent =. toJSON uContent' ]
|
|
in runConduit $ getQueuedJobs .| C.mapM_ updateQueuedJob
|
|
|
|
updateWhere [ SentMailRecipient ==. Just oldUserId ] [ SentMailRecipient =. Just newUserId ]
|
|
|
|
updateWhere [ SheetEditUser ==. oldUserId] [ SheetEditUser =. newUserId ]
|
|
|
|
let getSheetPseudonyms = selectSource [ SheetPseudonymUser ==. oldUserId ] []
|
|
upsertSheetPseudonym (Entity oldSPId oldSP) = do
|
|
collision <- existsBy $ UniqueSheetPseudonymUser (sheetPseudonymSheet oldSP) newUserId
|
|
if
|
|
| collision -> delete oldSPId
|
|
| otherwise -> update oldSPId [ SheetPseudonymUser =. newUserId ]
|
|
in runConduit $ getSheetPseudonyms .| C.mapM_ upsertSheetPseudonym
|
|
|
|
let getSheetCorrectors = selectSource [ SheetCorrectorUser ==. oldUserId ] []
|
|
upsertSheetCorrector (Entity oldSCId oldSheetCorrector) = do
|
|
collision <- getBy $ UniqueSheetCorrector newUserId (sheetCorrectorSheet oldSheetCorrector)
|
|
case collision of
|
|
Nothing -> update oldSCId [ SheetCorrectorUser =. newUserId ]
|
|
Just (Entity newSCId newSheetCorrector) -> do
|
|
update newSCId
|
|
[ SheetCorrectorLoad =. (sheetCorrectorLoad oldSheetCorrector <> sheetCorrectorLoad newSheetCorrector)
|
|
, SheetCorrectorState =. (min `on` sheetCorrectorState) oldSheetCorrector newSheetCorrector
|
|
]
|
|
delete oldSCId
|
|
in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector
|
|
|
|
do
|
|
collision <- E.selectMaybe . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
|
|
E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
|
|
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType
|
|
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle
|
|
E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
|
|
E.&&. personalisedSheetFileB E.^. PersonalisedSheetFileUser E.==. E.val newUserId
|
|
E.where_ . E.not_ $ personalisedSheetFileA E.^. PersonalisedSheetFileContent `E.maybeEq` personalisedSheetFileB E.^. PersonalisedSheetFileContent
|
|
return (personalisedSheetFileA, personalisedSheetFileB)
|
|
whenIsJust collision $ \(oldPersonalisedSheetFile, newPersonalisedSheetFile)
|
|
-> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile
|
|
E.insertSelectWithConflict
|
|
UniquePersonalisedSheetFile
|
|
(E.from $ \personalisedSheetFile -> do
|
|
E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
|
|
return $ PersonalisedSheetFile
|
|
E.<# (personalisedSheetFile E.^. PersonalisedSheetFileSheet)
|
|
E.<&> E.val newUserId
|
|
E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileType)
|
|
E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileTitle)
|
|
E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileContent)
|
|
E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileModified)
|
|
)
|
|
(\current excluded -> [ PersonalisedSheetFileModified E.=. E.max (current E.^. PersonalisedSheetFileModified) (excluded E.^. PersonalisedSheetFileModified) ])
|
|
deleteWhere [ PersonalisedSheetFileUser ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueTutor
|
|
(E.from $ \tutor -> do
|
|
E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId
|
|
return $ Tutor
|
|
E.<# (tutor E.^. TutorTutorial)
|
|
E.<&> E.val newUserId
|
|
)
|
|
(\_current _excluded -> [])
|
|
|
|
do
|
|
collision <- E.selectMaybe . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
|
|
E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
|
|
E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
|
|
E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
|
|
E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId
|
|
E.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId
|
|
E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId
|
|
E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup
|
|
return (tutorialParticipantA, tutorialParticipantB)
|
|
whenIsJust collision $ \(tutorialUserA, tutorialUserB)
|
|
-> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB
|
|
E.insertSelectWithConflict
|
|
UniqueTutorialParticipant
|
|
(E.from $ \tutorialParticipant -> do
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId
|
|
return $ TutorialParticipant
|
|
E.<# (tutorialParticipant E.^. TutorialParticipantTutorial)
|
|
E.<&> E.val newUserId
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ TutorialParticipantUser ==. oldUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueSystemMessageHidden
|
|
(E.from $ \systemMessageHidden -> do
|
|
E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId
|
|
return $ SystemMessageHidden
|
|
E.<# (systemMessageHidden E.^. SystemMessageHiddenMessage)
|
|
E.<&> E.val newUserId
|
|
E.<&> (systemMessageHidden E.^. SystemMessageHiddenTime)
|
|
)
|
|
(\current excluded -> [ SystemMessageHiddenTime E.=. combineWith current excluded E.max SystemMessageHiddenTime])
|
|
deleteWhere [ SystemMessageHiddenUser ==. oldUserId ]
|
|
|
|
let getStudyFeatures = selectSource [ StudyFeaturesUser ==. oldUserId ] []
|
|
upsertStudyFeatures (Entity oldSFId oldStudyFeatures) = do
|
|
collision <- getBy $ UniqueStudyFeatures newUserId (studyFeaturesDegree oldStudyFeatures) (studyFeaturesField oldStudyFeatures) (studyFeaturesType oldStudyFeatures) (studyFeaturesSemester oldStudyFeatures)
|
|
case collision of
|
|
Nothing -> update oldSFId [ StudyFeaturesUser =. newUserId ]
|
|
Just (Entity newSFId newStudyFeatures) -> do
|
|
update newSFId
|
|
[ StudyFeaturesSuperField =. ((<|>) `on` studyFeaturesSuperField) newStudyFeatures oldStudyFeatures
|
|
, StudyFeaturesFirstObserved =. (min `on` studyFeaturesFirstObserved) oldStudyFeatures newStudyFeatures
|
|
, StudyFeaturesLastObserved =. (max `on` studyFeaturesLastObserved) oldStudyFeatures newStudyFeatures
|
|
, StudyFeaturesValid =. ((||) `on` studyFeaturesValid) oldStudyFeatures newStudyFeatures
|
|
, StudyFeaturesRelevanceCached =. ((<|>) `on` studyFeaturesRelevanceCached) oldStudyFeatures newStudyFeatures
|
|
]
|
|
E.insertSelectWithConflict
|
|
UniqueRelevantStudyFeatures
|
|
(E.from $ \relevantStudyFeatures -> do
|
|
E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId
|
|
return $ RelevantStudyFeatures
|
|
E.<# (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm)
|
|
E.<&> E.val newSFId
|
|
)
|
|
(\_current _excluded -> [])
|
|
deleteWhere [ RelevantStudyFeaturesStudyFeatures ==. oldSFId ]
|
|
delete oldSFId
|
|
in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures
|
|
|
|
-- 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
|
|
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
|
|
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
|
|
updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
|
|
updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
|
|
E.insertSelectWithConflict
|
|
UniqueQualificationUser
|
|
(E.from $ \qualificationUser -> do
|
|
E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val oldUserId
|
|
return $ QualificationUser
|
|
E.<# E.val newUserId
|
|
E.<&> (qualificationUser E.^. QualificationUserQualification)
|
|
E.<&> (qualificationUser E.^. QualificationUserValidUntil)
|
|
E.<&> (qualificationUser E.^. QualificationUserLastRefresh)
|
|
E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
|
|
E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
|
|
)
|
|
(\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.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
|
|
return $ UserSupervisor
|
|
E.<# E.val newUserId
|
|
E.<&> (userSupervisor E.^. UserSupervisorUser)
|
|
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
|
|
)
|
|
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
|
|
deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueUserSupervisor
|
|
(E.from $ \userSupervisor -> do
|
|
E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
|
|
return $ UserSupervisor
|
|
E.<# (userSupervisor E.^. UserSupervisorSupervisor)
|
|
E.<&> E.val newUserId
|
|
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
|
|
)
|
|
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
|
|
deleteWhere [ UserSupervisorUser ==. oldUserId]
|
|
|
|
-- Companies, in conflict, keep the newUser-Company as is
|
|
E.insertSelectWithConflict
|
|
UniqueUserCompany
|
|
(E.from $ \userCompany -> do
|
|
E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
|
|
return $ UserCompany
|
|
E.<# E.val newUserId
|
|
E.<&> (userCompany E.^. UserCompanyCompany)
|
|
E.<&> (userCompany E.^. UserCompanySupervisor)
|
|
)
|
|
(\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
|
|
deleteWhere [ UserCompanyUser ==. oldUserId]
|
|
|
|
userIdents <- E.select . E.from $ \user -> do
|
|
E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId]
|
|
return ( user E.^. UserId
|
|
, user E.^. UserIdent
|
|
)
|
|
case (,) <$> List.lookup (E.Value oldUserId) userIdents <*> List.lookup (E.Value newUserId) userIdents of
|
|
Just (E.Value oldIdent, E.Value newIdent')
|
|
| oldIdent /= newIdent' -> audit $ TransactionUserIdentChanged oldIdent newIdent'
|
|
| otherwise -> return ()
|
|
_other -> tellError UserAssimilateCouldNotDetermineUserIdents
|
|
|
|
delete oldUserId
|
|
audit $ TransactionUserAssimilated newUserId oldUserId
|
|
where
|
|
tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) ()
|
|
tellWarning = lift . tellPoint . UserAssimilateException oldUserId newUserId
|
|
|
|
tellError :: forall a. UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) a
|
|
tellError = throwM . UserAssimilateException oldUserId newUserId
|
|
|
|
|
|
|
|
combineWith :: (PersistEntity val, PersistField typ1) =>
|
|
E.SqlExpr (Entity val)
|
|
-> E.SqlExpr (Entity val)
|
|
-> (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) |