784 lines
40 KiB
Haskell
784 lines
40 KiB
Haskell
module Handler.Utils.Users
|
|
( computeUserAuthenticationDigest
|
|
, Digest, SHA3_256
|
|
, constEq
|
|
, NameMatchQuality(..)
|
|
, matchesName
|
|
, GuessUserInfo(..)
|
|
, guessUser
|
|
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
|
|
, assimilateUser
|
|
) 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.CaseInsensitive as CI
|
|
|
|
import qualified Database.Esqueleto 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)
|
|
|
|
|
|
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
|
|
computeUserAuthenticationDigest = hashlazy . JSON.encode
|
|
|
|
|
|
data GuessUserInfo
|
|
= GuessUserMatrikelnummer { guessUserMatrikelnummer :: UserMatriculation }
|
|
| 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')
|
|
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)
|
|
| UserAssimilateCourseParticipantDifferentAllocation (Entity CourseParticipant) (Entity CourseParticipant)
|
|
| UserAssimilateSubmissionGroupUserMultiple (Entity SubmissionGroupUser) (Entity SubmissionGroupUser)
|
|
| UserAssimilateAllocationUserDifferentPriority (Entity AllocationUser) (Entity AllocationUser)
|
|
| UserAssimilateAllocationDeregisterDuplicateCourse (Entity AllocationDeregister) (Entity AllocationDeregister)
|
|
| 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)
|
|
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 ]
|
|
|
|
let getCourseApplications = selectSource [ CourseApplicationUser ==. oldUserId ] []
|
|
upsertCourseApplication (Entity oldAppId oldApp) = do
|
|
newApp <- selectList [CourseApplicationUser ==. newUserId, CourseApplicationCourse ==. courseApplicationCourse oldApp, CourseApplicationAllocation ==. courseApplicationAllocation oldApp] [LimitTo 1]
|
|
case newApp of
|
|
(_ : _) -> return ()
|
|
[] -> do
|
|
newAppId <- insert oldApp
|
|
{ courseApplicationUser = newUserId
|
|
}
|
|
updateWhere [ CourseApplicationFileApplication ==. oldAppId ] [ CourseApplicationFileApplication =. newAppId ]
|
|
delete oldAppId
|
|
in runConduit $ getCourseApplications .| C.mapM_ upsertCourseApplication
|
|
|
|
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 ]
|
|
|
|
do
|
|
collision <- E.selectMaybe . E.from $ \(courseParticipantA `E.InnerJoin` courseParticipantB) -> do
|
|
E.on $ courseParticipantA E.^. CourseParticipantCourse E.==. courseParticipantB E.^. CourseParticipantCourse
|
|
E.&&. courseParticipantA E.^. CourseParticipantUser E.==. E.val oldUserId
|
|
E.&&. courseParticipantB E.^. CourseParticipantUser E.==. E.val newUserId
|
|
E.where_ . E.isJust $ courseParticipantA E.^. CourseParticipantAllocated
|
|
E.where_ . E.isJust $ courseParticipantB E.^. CourseParticipantAllocated
|
|
return (courseParticipantA, courseParticipantB)
|
|
whenIsJust collision $ \(oldParticipant, newParticipant)
|
|
-> tellError $ UserAssimilateCourseParticipantDifferentAllocation oldParticipant newParticipant
|
|
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.^. CourseParticipantAllocated)
|
|
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)
|
|
, CourseParticipantAllocated E.=. E.alt (current E.^. CourseParticipantAllocated) (excluded E.^. CourseParticipantAllocated)
|
|
]
|
|
)
|
|
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 $ \(allocationUserA `E.InnerJoin` allocationUserB) -> do
|
|
E.on $ allocationUserA E.^. AllocationUserAllocation E.==. allocationUserB E.^. AllocationUserAllocation
|
|
E.&&. allocationUserA E.^. AllocationUserUser E.==. E.val oldUserId
|
|
E.&&. allocationUserB E.^. AllocationUserUser E.==. E.val newUserId
|
|
E.where_ $ allocationUserA E.^. AllocationUserPriority E.!=. allocationUserB E.^. AllocationUserPriority
|
|
return (allocationUserA, allocationUserB)
|
|
forM_ collisions $ \(oldAllocUser, newAllocUser)
|
|
-> tellWarning $ UserAssimilateAllocationUserDifferentPriority oldAllocUser newAllocUser
|
|
E.insertSelectWithConflict
|
|
UniqueAllocationUser
|
|
(E.from $ \allocationUser -> do
|
|
E.where_ $ allocationUser E.^. AllocationUserUser E.==. E.val oldUserId
|
|
return $ AllocationUser
|
|
E.<# (allocationUser E.^. AllocationUserAllocation)
|
|
E.<&> E.val newUserId
|
|
E.<&> (allocationUser E.^. AllocationUserTotalCourses)
|
|
E.<&> (allocationUser E.^. AllocationUserPriority)
|
|
)
|
|
(\current excluded -> [ AllocationUserTotalCourses E.=. E.max (current E.^. AllocationUserTotalCourses) (excluded E.^. AllocationUserTotalCourses) ])
|
|
deleteWhere [ AllocationUserUser ==. oldUserId ]
|
|
|
|
do
|
|
collisions <- E.select . E.from $ \(allocationDeregisterA `E.InnerJoin` allocationDeregisterB) -> do
|
|
E.on $ allocationDeregisterA E.^. AllocationDeregisterCourse E.==. allocationDeregisterB E.^. AllocationDeregisterCourse
|
|
E.&&. allocationDeregisterA E.^. AllocationDeregisterUser E.==. E.val oldUserId
|
|
E.&&. allocationDeregisterB E.^. AllocationDeregisterUser E.==. E.val newUserId
|
|
return (allocationDeregisterA, allocationDeregisterB)
|
|
forM_ collisions $ \(oldAllocationDeregister, newAllocationDeregister) ->
|
|
tellWarning $ UserAssimilateAllocationDeregisterDuplicateCourse oldAllocationDeregister newAllocationDeregister
|
|
updateWhere [ AllocationDeregisterUser ==. oldUserId ] [ AllocationDeregisterUser =. newUserId ]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueAllocationNotificationSetting
|
|
(E.from $ \allocNotifySetting -> do
|
|
E.where_ $ allocNotifySetting E.^. AllocationNotificationSettingUser E.==. E.val oldUserId
|
|
return $ AllocationNotificationSetting
|
|
E.<# E.val newUserId
|
|
E.<&> (allocNotifySetting E.^. AllocationNotificationSettingAllocation)
|
|
E.<&> (allocNotifySetting E.^. AllocationNotificationSettingIsOptOut)
|
|
)
|
|
(\current excluded -> [ AllocationNotificationSettingIsOptOut E.=. (current E.^. AllocationNotificationSettingIsOptOut E.||. excluded E.^. AllocationNotificationSettingIsOptOut) ])
|
|
deleteWhere [ AllocationNotificationSettingUser ==. 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 (return ()) $ 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.=. E.max (current E.^. SystemMessageHiddenTime) (excluded E.^. 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
|
|
|
|
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
|