1114 lines
57 KiB
Haskell
1114 lines
57 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.de>, 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>,Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
-- NOTE: Also see Handler.Utils.Profile for similar utilities
|
|
module Handler.Utils.Users
|
|
( computeUserAuthenticationDigest
|
|
, Digest, SHA3_256
|
|
, constEq
|
|
, NameMatchQuality(..)
|
|
, matchesName
|
|
, GuessUserInfo(..)
|
|
, guessUser, guessUserByEmail
|
|
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
|
|
, assimilateUser
|
|
, getUserPrimaryCompany, getUserPrimaryCompanyAddress
|
|
, getUserEmail
|
|
, getEmailAddress, getJustEmailAddress
|
|
, getUserEmailAutomatic
|
|
, getEmailAddressFor, getJustEmailAddressFor
|
|
, getPostalAddress, getPostalAddress'
|
|
, getPostalPreferenceAndAddress, getPostalPreferenceAndAddress'
|
|
, abbrvName
|
|
, getReceivers, getReceiversFor
|
|
, getSupervisees
|
|
) where
|
|
|
|
import Import
|
|
import Foundation.Yesod.Auth (userLookupAndUpsert)
|
|
|
|
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 Database.Esqueleto.Experimental ((:&)(..))
|
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
|
import qualified Database.Esqueleto.Legacy as EL (on,from)
|
|
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 Handler.Utils.Profile
|
|
|
|
import Jobs.Types(Job, JobChildren)
|
|
|
|
data ExceptionUserHandling
|
|
= ExceptionUserHasNoEmail
|
|
deriving (Eq, Ord, Read, Show, Generic) -- Enum, Bounded,
|
|
instance Exception ExceptionUserHandling
|
|
|
|
|
|
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 "."
|
|
|
|
|
|
-- | Retrieve primary company association for user.
|
|
-- Warning: if there are multiple associations witht the same priority, one with rerouting and supervision are preferred, them alphabetically
|
|
-- Note that Entity Company can be retrieved, since CompanyShorthand is the DB key.
|
|
getUserPrimaryCompany :: UserId -> DBRead' (Maybe UserCompany)
|
|
getUserPrimaryCompany uid = entityVal <<$>>
|
|
selectFirst [UserCompanyUser ==. uid]
|
|
[Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany]
|
|
|
|
getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DBRead' (Maybe a)
|
|
getUserPrimaryCompanyAddress uid prj = runMaybeT $ do
|
|
UserCompany{userCompanyCompany=cid, userCompanyUseCompanyAddress=True} <- MaybeT $ getUserPrimaryCompany uid -- return Nothing if company address is not to be used
|
|
company <- MaybeT $ get cid
|
|
-- hoistMaybe $ prj company
|
|
MaybeT $ pure $ prj company
|
|
|
|
|
|
-- | Compute actual address for user; returning True for Postal preference, as well as address (user or company) and primary e-mail
|
|
-- result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
|
|
getPostalPreferenceAndAddress :: Entity User -> DBRead' (Bool, Maybe [Text], Maybe UserEmail)
|
|
getPostalPreferenceAndAddress usr = do
|
|
pa <- getPostalAddress usr
|
|
em <- getUserEmail usr
|
|
let usrPrefPost = usr ^. _entityVal . _userPrefersPostal
|
|
finalPref = (usrPrefPost && isJust pa) || isNothing em
|
|
-- finalPref = isJust pa && (usrPrefPost || isNothing em)
|
|
return (finalPref, pa, em)
|
|
|
|
-- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known
|
|
-- primed variant returns storedMarkup without prefixed userDisplayName
|
|
getPostalPreferenceAndAddress' :: Entity User -> DBReadUq' (Bool, (Maybe StoredMarkup, Bool), (Maybe UserEmail, Bool))
|
|
getPostalPreferenceAndAddress' usr = do
|
|
pa <- getPostalAddress' usr
|
|
em <- getUserEmailAutomatic usr
|
|
let usrPrefPost = usr ^. _entityVal . _userPrefersPostal
|
|
finalPref = (usrPrefPost && isJust (fst pa)) || isNothing (fst em)
|
|
-- finalPref = isJust (fst pa) && (usrPrefPost || isNothing (fst em))
|
|
return (finalPref, pa, em)
|
|
|
|
getEmailAddressFor :: UserId -> DBRead' (Maybe Address)
|
|
getEmailAddressFor = maybeM (return Nothing) getEmailAddress . getEntity
|
|
|
|
getJustEmailAddressFor :: UserId -> DBRead' Address
|
|
getJustEmailAddressFor = maybeThrowM ExceptionUserHasNoEmail . getEmailAddressFor
|
|
|
|
getJustEmailAddress :: Entity User -> DBRead' Address
|
|
getJustEmailAddress = maybeThrowM ExceptionUserHasNoEmail . getEmailAddress
|
|
|
|
getEmailAddress :: Entity User -> DBRead' (Maybe Address)
|
|
getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr
|
|
where toAddress = Address (Just userDisplayName) . CI.original
|
|
|
|
getUserEmail :: Entity User -> DBRead' (Maybe UserEmail)
|
|
getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
|
|
| validEmail' userDisplayEmail
|
|
= return $ Just userDisplayEmail
|
|
| otherwise
|
|
= do
|
|
compEmailMb <- getUserPrimaryCompanyAddress uid companyEmail
|
|
return $ pickValidEmail' $ mcons compEmailMb [userEmail]
|
|
|
|
-- like `getUserEmail`, but also checks whether the Email will be update automatically
|
|
getUserEmailAutomatic :: Entity User -> DBReadUq' (Maybe UserEmail, Bool)
|
|
getUserEmailAutomatic Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
|
|
| validEmail' userDisplayEmail
|
|
= do
|
|
muavs <- getBy $ UniqueUserAvsUser uid
|
|
let auto = userDisplayEmail == muavs ^. _Just . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI -- Recall: _Just on Nothing yields mempty here
|
|
|| userDisplayEmail == muavs ^. _Just . _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . _Just . from _CI
|
|
return (Just userDisplayEmail, auto)
|
|
| otherwise
|
|
= getUserPrimaryCompanyAddress uid companyEmail >>= \case
|
|
Just compEmail | validEmail' compEmail -> return (Just compEmail, True )
|
|
Nothing | validEmail' userEmail -> return (Just userEmail, False)
|
|
_ -> return (Nothing , False)
|
|
|
|
-- address is prefixed with userDisplayName
|
|
getPostalAddress :: Entity User -> DBRead' (Maybe [Text])
|
|
getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
|
|
| (Just upo) <- userPostAddress, validPostAddress userPostAddress
|
|
= prefixMarkupName upo
|
|
| otherwise
|
|
= do
|
|
getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
|
|
(Just pa)
|
|
-> prefixMarkupName pa
|
|
Nothing
|
|
| Just abt <- userCompanyDepartment
|
|
-> return $ Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
|
|
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
|
|
| otherwise -> return Nothing
|
|
where
|
|
prefixMarkupName = return . Just . (userDisplayName :) . html2textlines
|
|
|
|
-- primed variant returns storedMarkup without prefixed userDisplayName and whether updates are automatic
|
|
getPostalAddress' :: Entity User -> DBReadUq' (Maybe StoredMarkup, Bool)
|
|
getPostalAddress' Entity{entityKey=uid, entityVal=User{..}}
|
|
| validPostAddress userPostAddress
|
|
= do
|
|
muavs <- getBy $ UniqueUserAvsUser uid
|
|
let auto = userPostAddress == muavs ^? _Just . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just -- Recall: using _Just with ^. on Nothing yields mempty
|
|
return (userPostAddress, auto)
|
|
| otherwise
|
|
= do
|
|
getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
|
|
res@(Just _)
|
|
-> return (res, True)
|
|
Nothing
|
|
| Just abt <- userCompanyDepartment
|
|
-> return $ (,True) $ Just $ plaintextToStoredMarkup $ textUnlines $
|
|
if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
|
|
| otherwise -> [userDisplayName, abt, "Hausbriefkasten" ]
|
|
| otherwise -> return (Nothing, True)
|
|
|
|
-- | Consider using Handler.Utils.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
|
|
directResult = return (underling, [underling], True)
|
|
if null superIds
|
|
then directResult
|
|
else do
|
|
receivers <- selectList [UserId <-. superIds] []
|
|
if null receivers
|
|
then directResult
|
|
else return (underling, receivers, uid `elem` (entityKey <$> receivers))
|
|
|
|
-- | For user with mailTdirect, since this query will also return supervisors that have reroute supervisors themselves, who would then receive multiple duplicates
|
|
getReceiversFor :: (MonoFoldable mono, UserId ~ Element mono) => mono -> DB [UserId]
|
|
getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do
|
|
usr :& spr <- E.from $ E.table @User `E.leftJoin` E.table @UserSupervisor
|
|
`E.on` (\(usr :& spr) -> usr E.^. UserId E.=?. spr E.?. UserSupervisorUser E.&&. E.isTrue (spr E.?. UserSupervisorRerouteNotifications))
|
|
E.where_ $ usr E.^. UserId `E.in_` E.vals uids
|
|
return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId
|
|
|
|
-- | return uid and underlings for currently logged in user, empty if not logged in
|
|
getSupervisees :: Bool -> DB (Set UserId)
|
|
getSupervisees forceLogin = do
|
|
mbuid <- if forceLogin
|
|
then Just <$> requireAuthId -- forces login
|
|
else maybeAuthId
|
|
flip foldMapM mbuid $ \uid -> do
|
|
svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
|
|
return $ Set.insert uid $ Set.fromAscList svs
|
|
|
|
|
|
computeUserAuthenticationDigest :: Maybe Text -> Digest SHA3_256
|
|
computeUserAuthenticationDigest = hashlazy . JSON.encode
|
|
|
|
-- guessUserByCompanyPersonalNumber :: Text -> Text -> DB (Maybe UserId)
|
|
-- guessUserByCompanyPersonalNumber surname ipn = getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn, UserSurname ==. surname]
|
|
|
|
guessUserByEmail :: UserEmail -> DB (Maybe UserId)
|
|
guessUserByEmail eml = firstJustM $
|
|
[ getKeyBy $ UniqueEmail eml
|
|
, getKeyBy $ UniqueAuthentication eml -- aka UserIdent
|
|
, getKeyByFilter [UserDisplayEmail ==. eml]
|
|
] <> maybeEmpty (getFraportLogin (CI.original eml)) (\lgi ->
|
|
[ getKeyBy $ UniqueLdapPrimaryKey $ Just lgi
|
|
])
|
|
|
|
data GuessUserInfo
|
|
= GuessUserMatrikelnummer
|
|
{ guessUserMatrikelnummer :: UserMatriculation }
|
|
| GuessUserDisplayName
|
|
{ guessUserDisplayName :: UserDisplayName }
|
|
| GuessUserSurname
|
|
{ guessUserSurname :: UserSurname }
|
|
| GuessUserFirstName
|
|
{ guessUserFirstName :: UserFirstName }
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
instance Binary GuessUserInfo
|
|
|
|
makeLenses_ ''GuessUserInfo
|
|
|
|
data NameMatchQuality
|
|
= NameMatchSuffix
|
|
| NameMatchPrefix
|
|
| NameMatchPermutation
|
|
| NameMatchEqual
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
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 didUpsert = do
|
|
let retrieveUsers = E.select . EL.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]
|
|
|
|
doUpsert = flip userLookupAndUpsert UpsertUserGuessUser
|
|
|
|
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
|
|
|
|
convertUpsertResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
|
|
convertUpsertResults [] = Nothing
|
|
convertUpsertResults [x] = Just $ Right x
|
|
convertUpsertResults xs = Just $ Left $ NonEmpty.fromList xs
|
|
|
|
if
|
|
| [x] <- users'
|
|
, Just True == matchesMatriculation x || didUpsert
|
|
-> return $ Just $ Right x
|
|
| x : x' : _ <- users'
|
|
, Just True == matchesMatriculation x || didUpsert
|
|
, GT <- x `closeness` x'
|
|
-> return $ Just $ Right x
|
|
| xs@(x:_:_) <- takeClosest users'
|
|
, Just True == matchesMatriculation x || didUpsert
|
|
-> return $ Just $ Left $ NonEmpty.fromList xs
|
|
| not didUpsert
|
|
, userMatrs <- ((Set.toList . Set.fromList) (mapMaybe getTermMatr criteria))
|
|
-> mapM doUpsert userMatrs >>= maybe (go True) (return . Just) . convertUpsertResults . catMaybes
|
|
| otherwise
|
|
-> return Nothing
|
|
|
|
|
|
data UserAssimilateException = UserAssimilateException
|
|
{ userAssimilateOldUser, userAssimilateNewUser :: UserId
|
|
, userAssimilateException :: UserAssimilateExceptionReason
|
|
} deriving (Eq, Ord, Show, Generic)
|
|
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)
|
|
|
|
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
|
|
-- retrieve user entities first, to ensure they both exist
|
|
(oldUserEnt, newUserEnt) <- do
|
|
oldUser <- getEntity oldUserId
|
|
newUser <- getEntity newUserId
|
|
case (oldUser, newUser) of
|
|
(Just old, Just new) -> return (old,new)
|
|
_ -> tellError UserAssimilateCouldNotDetermineUserIdents
|
|
let oldUser = oldUserEnt ^. _entityVal
|
|
newUser = newUserEnt ^. _entityVal
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueCourseFavourite
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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 . EL.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 . EL.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
|
|
(EL.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
|
|
(EL.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 . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
|
|
EL.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
|
|
EL.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
|
|
E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId
|
|
E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId
|
|
EL.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
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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
|
|
(EL.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 . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
|
|
EL.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
|
|
(EL.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.selectOne . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
|
|
EL.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
|
|
(EL.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.selectOne . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
|
|
EL.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
|
|
(EL.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
|
|
(EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
|
|
EL.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.selectOne . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
|
|
EL.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
|
|
(EL.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
|
|
(EL.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.selectOne . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
|
|
EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
|
|
EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
|
|
E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
|
|
E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId
|
|
EL.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
|
|
(EL.from $ \tutorialParticipant -> do
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId
|
|
return $ TutorialParticipant
|
|
E.<# (tutorialParticipant E.^. TutorialParticipantTutorial)
|
|
E.<&> E.val newUserId
|
|
E.<&> (tutorialParticipant E.^. TutorialParticipantCompany)
|
|
E.<&> (tutorialParticipant E.^. TutorialParticipantDrivingPermit)
|
|
E.<&> (tutorialParticipant E.^. TutorialParticipantEyeExam)
|
|
E.<&> (tutorialParticipant E.^. TutorialParticipantNote)
|
|
)
|
|
(\_current _excluded -> [])
|
|
E.insertSelectWithConflict
|
|
UniqueTutorialParticipantDay
|
|
(EL.from $ \tutorialParticipantDay -> do
|
|
E.where_ $ tutorialParticipantDay E.^. TutorialParticipantDayUser E.==. E.val oldUserId
|
|
return $ TutorialParticipantDay
|
|
E.<# (tutorialParticipantDay E.^. TutorialParticipantDayTutorial)
|
|
E.<&> E.val newUserId
|
|
E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayDay)
|
|
E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayAttendance)
|
|
E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayNote)
|
|
)
|
|
(\current excluded ->
|
|
[ TutorialParticipantDayAttendance E.=. (current E.^. TutorialParticipantDayAttendance E.||. excluded E.^. TutorialParticipantDayAttendance)
|
|
, TutorialParticipantDayNote E.=. E.coalesce [current E.^. TutorialParticipantDayNote, excluded E.^. TutorialParticipantDayNote]
|
|
]
|
|
)
|
|
deleteWhere [ TutorialParticipantDayUser ==. oldUserId ]
|
|
deleteWhere [ TutorialParticipantUser ==. oldUserId ]
|
|
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueSystemMessageHidden
|
|
(EL.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
|
|
(EL.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 UniqueLmsQualificationUuser
|
|
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 ]
|
|
usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
|
|
EL.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
|
|
E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId
|
|
)
|
|
E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId
|
|
return (oldQual, newQual)
|
|
forM_ usrQualis $ \case
|
|
(Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join
|
|
(Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do
|
|
updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ]
|
|
update newQKey
|
|
[ QualificationUserValidUntil =. (max `on` view _qualificationUserValidUntil ) oldQUsr newQUsr
|
|
, QualificationUserLastRefresh =. (max `on` view _qualificationUserLastRefresh ) oldQUsr newQUsr
|
|
, QualificationUserFirstHeld =. (min `on` view _qualificationUserFirstHeld ) oldQUsr newQUsr
|
|
, QualificationUserScheduleRenewal =. (max `on` view _qualificationUserScheduleRenewal) oldQUsr newQUsr
|
|
, QualificationUserLastNotified =. (max `on` view _qualificationUserLastNotified ) oldQUsr newQUsr
|
|
]
|
|
delete oldQKey
|
|
-- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed
|
|
|
|
-- PrintJobs
|
|
updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ]
|
|
updateWhere [ PrintJobSender ==. Just oldUserId ] [ PrintJobSender =. Just newUserId ]
|
|
|
|
-- Supervision is fully merged
|
|
E.insertSelectWithConflict
|
|
UniqueUserSupervisor
|
|
(EL.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)
|
|
E.<&> (userSupervisor E.^. UserSupervisorCompany)
|
|
E.<&> (userSupervisor E.^. UserSupervisorReason)
|
|
)
|
|
(\current excluded ->
|
|
[ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
|
|
, UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
|
|
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
|
|
] )
|
|
deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueUserSupervisor
|
|
(EL.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)
|
|
E.<&> (userSupervisor E.^. UserSupervisorCompany)
|
|
E.<&> (userSupervisor E.^. UserSupervisorReason)
|
|
)
|
|
(\current excluded ->
|
|
[ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)
|
|
, UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany]
|
|
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason]
|
|
] )
|
|
deleteWhere [ UserSupervisorUser ==. oldUserId]
|
|
|
|
-- Companies, in conflict, keep the newUser-Company as is
|
|
E.insertSelectWithConflict
|
|
UniqueUserCompany
|
|
(EL.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)
|
|
E.<&> (userCompany E.^. UserCompanySupervisorReroute)
|
|
E.<&> (userCompany E.^. UserCompanyPriority)
|
|
E.<&> (userCompany E.^. UserCompanyUseCompanyAddress)
|
|
E.<&> (userCompany E.^. UserCompanyReason)
|
|
)
|
|
(\current excluded ->
|
|
[ UserCompanySupervisor E.=. E.greatest (current E.^. UserCompanySupervisor) (excluded E.^. UserCompanySupervisor) -- t > f
|
|
, UserCompanyPriority E.=. E.greatest (current E.^. UserCompanyPriority) (excluded E.^. UserCompanyPriority)
|
|
, UserCompanyUseCompanyAddress E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress)
|
|
, UserCompanyReason E.=. E.coalesce [current E.^. UserCompanyReason ,excluded E.^. UserCompanyReason]
|
|
]
|
|
)
|
|
deleteWhere [ UserCompanyUser ==. oldUserId]
|
|
|
|
E.insertSelectWithConflict
|
|
UniqueUserDay
|
|
(EL.from $ \userDay -> do
|
|
E.where_ $ userDay E.^. UserDayUser E.==. E.val oldUserId
|
|
return $ UserDay
|
|
E.<# E.val newUserId
|
|
E.<&> (userDay E.^. UserDayDay)
|
|
E.<&> (userDay E.^. UserDayParkingToken)
|
|
)
|
|
(\current excluded ->
|
|
[ UserDayParkingToken E.=. (current E.^. UserDayParkingToken E.||. excluded E.^. UserDayParkingToken)
|
|
]
|
|
)
|
|
deleteWhere [ UserDayUser ==. oldUserId]
|
|
|
|
mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId
|
|
mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId
|
|
case (mbOldAvsId,mbNewAvsId) of
|
|
(Nothing, _)
|
|
-> return ()
|
|
(Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _)
|
|
-> deleteBy (UniqueUserAvsId oldAvsId)
|
|
(Just Entity{entityVal=oldUserAvs}, Nothing)
|
|
-> void $ upsertBySafe (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} (_userAvsUser .~ newUserId)
|
|
|
|
-- merge some optional / incomplete user fields
|
|
let mergeBy :: forall a . PersistField a => (a -> a -> Bool) -> EntityField User a -> Maybe (Update User)
|
|
mergeBy cmp uf = let ufl = fieldLens uf
|
|
oldV = oldUserEnt ^. ufl
|
|
newV = newUserEnt ^. ufl
|
|
in toMaybe (cmp oldV newV) (uf =. oldV)
|
|
|
|
mergeMaybe :: forall b . PersistField b => EntityField User (Maybe b) -> Maybe (Update User)
|
|
mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)
|
|
|
|
update newUserId $ catMaybes -- NOTE: persist does shortcircuit null updates as expected
|
|
[ mergeMaybe UserPasswordHash
|
|
, mergeBy (>) UserLastAuthentication
|
|
, mergeBy (<) UserCreated
|
|
, toMaybe (not (validEmail' (newUser ^. _userEmail )) && validEmail' (oldUser ^. _userEmail))
|
|
(UserEmail =. oldUser ^. _userEmail)
|
|
, toMaybe (not (validEmail' (newUser ^. _userDisplayEmail)) && validEmail' (oldUser ^. _userDisplayEmail))
|
|
(UserDisplayEmail =. oldUser ^. _userDisplayEmail)
|
|
, mergeMaybe UserMatrikelnummer
|
|
, toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress))
|
|
(UserPostAddress =. oldUser ^. _userPostAddress)
|
|
, toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress))
|
|
(UserPostLastUpdate =. oldUser ^. _userPostLastUpdate)
|
|
, toMaybe ((isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress))
|
|
&& (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal))
|
|
(UserPrefersPostal =. True)
|
|
, mergeMaybe UserPinPassword
|
|
, mergeMaybe UserLanguages
|
|
, mergeMaybe UserSex
|
|
, mergeMaybe UserBirthday
|
|
, mergeMaybe UserTelephone
|
|
, mergeMaybe UserMobile
|
|
]
|
|
|
|
delete oldUserId
|
|
let oldUsrIdent = oldUser ^. _userIdent
|
|
newUsrIdent = newUser ^. _userIdent
|
|
when (oldUsrIdent /= newUsrIdent) $ audit $ TransactionUserIdentChanged oldUsrIdent newUsrIdent
|
|
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)
|