fix(avs): fix #36 and remove dead code
This commit is contained in:
parent
b7af6312f9
commit
4f8850b3b4
@ -26,17 +26,6 @@ UserAvs
|
||||
UniqueUserAvsId personId
|
||||
deriving Generic Show
|
||||
|
||||
-- Multiple UserAvsCards per UserAvs is possible and not too uncommon.
|
||||
-- Purpose of saving cards is to detect external changes in qualifications and postal addresses
|
||||
-- TODO: This table will be deleted if AVS CR3 SCF-165 is implemented
|
||||
UserAvsCard
|
||||
personId AvsPersonId
|
||||
cardNo AvsFullCardNo
|
||||
card AvsDataPersonCard
|
||||
lastSynch UTCTime
|
||||
-- UniqueAvsCard cardNo -- Note: cardNo is not unique; invalid cardNo may be reissued to different persons
|
||||
deriving Generic
|
||||
|
||||
AvsSync
|
||||
user UserId -- Note: we need to lookup UserAvs Entity anyway, so no benefit from storing AvsPersonId here
|
||||
creationTime UTCTime
|
||||
|
||||
@ -37,7 +37,7 @@ import Import
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Control.Monad.Catch as Catch
|
||||
|
||||
@ -105,194 +105,6 @@ catchAVS2message act = act `catches` handlers
|
||||
-- AVS Handlers --
|
||||
------------------
|
||||
|
||||
{-
|
||||
-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; fail-safe, may or may not update existing users, may insert new users
|
||||
-- If an existing User with internal number is found, an AVS update query is executed
|
||||
guessAvsUser :: Text -> Handler (Maybe UserId)
|
||||
guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidTxt) Nothing $ \avsidNr ->
|
||||
let avsid = AvsPersonId avsidNr
|
||||
maybeAvsUpsert = maybeCatchAll $ upsertAvsUserById avsid
|
||||
extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
|
||||
in maybeM maybeAvsUpsert extractUid $ runDB $ getBy $ UniqueUserAvsId avsid
|
||||
guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoTxt) Nothing $ \avsno ->
|
||||
runDB (selectList [UserAvsNoPerson ==. avsno] []) <&> \case
|
||||
[Entity _ UserAvs{userAvsUser=uid}] -> Just uid
|
||||
_ -> Nothing
|
||||
guessAvsUser someid = do
|
||||
let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard
|
||||
case discernAvsCardPersonalNo someid of
|
||||
Just cid@(Right _cardNo) -> maybeUpsertAvsUserByCard cid
|
||||
-- NOTE: card validity might be outdated, so we must always check with avs
|
||||
-- maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ do
|
||||
-- let extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
|
||||
-- extractUidCard UserAvsCard{userAvsCardPersonId=avid} = getBy $ UniqueUserAvsId avid
|
||||
-- cards <- selectList [UserAvsCardCardNo ==. cardNo] []
|
||||
-- case [c | cent <- cards, let c = entityVal cent, avsDataValid (userAvsCardCard c)] of
|
||||
-- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard)
|
||||
-- _ -> return Nothing
|
||||
Just cid@(Left _wholeNumber) ->
|
||||
maybeUpsertAvsUserByCard cid >>= \case
|
||||
Nothing ->
|
||||
runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case
|
||||
[Entity uid _] -> return $ Just uid
|
||||
_ -> return Nothing
|
||||
uid -> return uid
|
||||
Nothing -> try (runDB $ ldapLookupAndUpsert someid) >>= \case
|
||||
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} ->
|
||||
maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Left $ mkAvsInternalPersonalNo persNo))
|
||||
Right Entity{entityKey=uid} -> return $ Just uid
|
||||
other -> do -- attempt to recover by trying other ids
|
||||
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
|
||||
runDB . runMaybeT $
|
||||
let someIdent = stripCI someid
|
||||
in MaybeT (getKeyBy $ UniqueEmail someIdent)
|
||||
<|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
|
||||
-}
|
||||
{-
|
||||
-- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Address
|
||||
upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
|
||||
upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
|
||||
upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
|
||||
try (runDB $ ldapLookupAndUpsert otherId) >>= \case
|
||||
Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Left $ mkAvsInternalPersonalNo persNo)
|
||||
other -> do -- attempt to recover by trying other ids
|
||||
whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all
|
||||
apid <- runDB . runMaybeT $ do
|
||||
let someIdent = stripCI otherId
|
||||
uid <- MaybeT (getKeyBy $ UniqueEmail someIdent)
|
||||
<|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
|
||||
MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid)
|
||||
ifMaybeM apid Nothing upsertAvsUserById
|
||||
-}
|
||||
{-
|
||||
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
|
||||
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
|
||||
upsertAvsUserByCard :: Either AvsInternalPersonalNo AvsFullCardNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
|
||||
upsertAvsUserByCard persNo = do
|
||||
let qry = case persNo of
|
||||
Right AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
|
||||
Left fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn }
|
||||
AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
|
||||
AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry
|
||||
case Set.elems adps of
|
||||
[] -> throwM AvsPersonSearchEmpty
|
||||
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
||||
[AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always trigger an update
|
||||
-- do
|
||||
-- mbuid <- runDB $ getBy $ UniqueUserAvsId api
|
||||
-- case mbuid of
|
||||
-- (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
|
||||
-- Nothing -> upsertAvsUserById api
|
||||
-}
|
||||
|
||||
|
||||
-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS Licence status! Updates Company, Address, PinPassword
|
||||
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen).
|
||||
upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId)
|
||||
upsertAvsUserById api = do
|
||||
mbapd <- lookupAvsUser api
|
||||
now <- liftIO getCurrentTime
|
||||
mbuid <- runDB $ do
|
||||
mbuid <- getBy (UniqueUserAvsId api)
|
||||
case (mbuid, mbapd) of
|
||||
(Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number
|
||||
| Just (avsInternalPersonalNo -> persNo) <- canonical avsPersonInternalPersonalNo -> do
|
||||
$logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo
|
||||
candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
|
||||
case candidates of
|
||||
[uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing Nothing) -- TODO info
|
||||
(_:_) -> throwM $ AvsUserAmbiguous api
|
||||
[] -> do
|
||||
upsRes :: Either SomeException (Entity User)
|
||||
<- try $ ldapLookupAndUpsert persNo
|
||||
$logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
|
||||
case upsRes of
|
||||
Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing Nothing -- pin/addr are updated in next step anyway -- TODO info
|
||||
Left err -> do
|
||||
$logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err
|
||||
return mbuid -- == Nothing -- user could not be created somehow
|
||||
(Just Entity{ entityKey = uaid }, _) -> do
|
||||
update uaid [ UserAvsLastSynch =. now, UserAvsLastSynchError =. Nothing ] -- mark as updated early, to prevent failed users to clog the synch
|
||||
return mbuid
|
||||
_other -> return mbuid
|
||||
$logInfoS "AVS" $ "upsert prestep result: " <> tshow mbuid <> " --- " <> tshow mbapd
|
||||
case (mbuid, mbapd) of
|
||||
( _ , Nothing ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet
|
||||
(Nothing, Just AvsDataPerson{avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname, ..}) -> do -- No LDAP User, but found in AVS; create new user
|
||||
let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards
|
||||
userFirmAddr= plaintextToStoredMarkup <$> mbCoFirmAddr
|
||||
pinCard = Set.lookupMax avsPersonPersonCards
|
||||
userPin = personCard2pin <$> pinCard
|
||||
fakeIdent = CI.mk $ "AVSID:" <> tshow api
|
||||
fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo
|
||||
newUsr = AddUserData
|
||||
{ audTitle = Nothing
|
||||
, audFirstName = avsFirstName
|
||||
, audSurname = avsSurname
|
||||
, audDisplayName = avsFirstName <> Text.cons ' ' avsSurname
|
||||
, audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
|
||||
, audMatriculation = Just $ tshow avsPersonPersonNo
|
||||
, audSex = Nothing
|
||||
, audBirthday = Nothing
|
||||
, audMobile = Nothing
|
||||
, audTelephone = Nothing
|
||||
, audFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
|
||||
, audFDepartment = Nothing
|
||||
, audPostAddress = userFirmAddr
|
||||
, audPrefersPostal = True
|
||||
, audPinPassword = userPin
|
||||
, audEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
|
||||
, audIdent = fakeIdent -- use AvsPersonId instead
|
||||
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
|
||||
}
|
||||
mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
|
||||
whenIsJust mbUid $ \uid -> runDB $ do
|
||||
insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing Nothing Nothing Nothing -- TODO info
|
||||
forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred
|
||||
-- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
|
||||
-- forM_ cs $ -- only save used cards for the postal address update detection
|
||||
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now
|
||||
oldUpsertUserCompany uid mbCompany userFirmAddr
|
||||
return mbUid
|
||||
|
||||
(Just (Entity _ UserAvs{userAvsUser=uid})
|
||||
, Just AvsDataPerson{avsPersonPersonCards, avsPersonInternalPersonalNo, avsPersonPersonNo, avsPersonFirstName= Text.strip -> avsFirstName, avsPersonLastName= Text.strip -> avsSurname}) -> do -- known user, update address and pinPassword
|
||||
let (mbCompany, mbCoFirmAddr, _) = guessLicenceAddress avsPersonPersonCards
|
||||
userFirmAddr = plaintextToStoredMarkup <$> mbCoFirmAddr
|
||||
pinCard = Set.lookupMax avsPersonPersonCards
|
||||
userPin = personCard2pin <$> pinCard
|
||||
runDB $ do
|
||||
update uid [ UserFirstName =. avsFirstName -- update in case of name changes via AVS; might be changed again through LDAP
|
||||
, UserSurname =. avsSurname
|
||||
, UserDisplayName =. avsFirstName <> Text.cons ' ' avsSurname
|
||||
, UserMatrikelnummer =. Just (tshow avsPersonPersonNo) -- TODO: Deactivate this update after Q2/2023; this is only needed since UserMatrikelnummer was used for AVSNO later
|
||||
, UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
|
||||
]
|
||||
oldCards <- selectList [UserAvsCardPersonId ==. api] []
|
||||
let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards -- TODO: get rid of getCompanyAddress
|
||||
unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before
|
||||
encRecipient :: CryptoUUIDUser <- encrypt uid
|
||||
$logInfoS "AVS" $ "Postal address updated for" <> tshow encRecipient
|
||||
updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr, UserPostLastUpdate =. Just now]
|
||||
whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card
|
||||
unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do
|
||||
let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards
|
||||
updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged
|
||||
[UserPinPassword =. userPin]
|
||||
insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now
|
||||
oldUpsertUserCompany uid mbCompany userFirmAddr
|
||||
forM_ avsPersonPersonCards $ \aCard -> do
|
||||
let fcn = getFullCardNo aCard
|
||||
-- probably not efficient, but fixes the problem that AvsCardNo is not unique as assumed before and may get reused
|
||||
deleteWhere [UserAvsCardCardNo ==. fcn]
|
||||
insert_ $ UserAvsCard
|
||||
{ userAvsCardPersonId = api
|
||||
, userAvsCardCardNo = fcn
|
||||
, userAvsCardCard = aCard
|
||||
, userAvsCardLastSynch = now
|
||||
}
|
||||
return $ Just uid
|
||||
|
||||
|
||||
-- TODO: delete lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored!
|
||||
lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
@ -322,7 +134,7 @@ updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
|
||||
updateReceivers uid = do
|
||||
-- First perform AVS update for receiver
|
||||
runDB (getBy (UniqueUserAvsUser uid)) >>= \case
|
||||
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ upsertAvsUserById apid
|
||||
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> void . maybeCatchAll $ Just <$> upsertAvsUserById apid
|
||||
Nothing -> return ()
|
||||
-- Retrieve updated user and supervisors now
|
||||
(underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
|
||||
@ -339,8 +151,8 @@ updateReceivers uid = do
|
||||
let (superVs, avsIds) = unzip avsSupers
|
||||
receiverIDs :: [UserId] = E.unValue <$> superVs
|
||||
toUpdate = Set.fromList $ mapMaybe E.unValue avsIds
|
||||
directResult = return (underling, pure underling, True) -- already contains updated address
|
||||
forM_ toUpdate (void . maybeCatchAll . upsertAvsUserById) -- attempt to update postaddress from AVS
|
||||
directResult = return (underling, pure underling, True) -- already contains updated address
|
||||
forM_ toUpdate (void . maybeCatchAll . fmap Just . upsertAvsUserById) -- attempt to update postaddress from AVS
|
||||
if null receiverIDs
|
||||
then directResult
|
||||
else do
|
||||
@ -357,10 +169,10 @@ updateReceivers uid = do
|
||||
-- DONE Update UserCompany too
|
||||
-- DONE #124 Add an old default supervisor to an Admin TODO-List
|
||||
-- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen
|
||||
-- TODO #36 "company postal preference", but for updates only yet
|
||||
-- DONE #36 "company postal preference", but for updates only yet
|
||||
--
|
||||
-- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do
|
||||
-- TODO: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables
|
||||
-- DONE: replace upsertAvsUserById with upsertAvsUserById0 and delete old code and old tables
|
||||
|
||||
-- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
|
||||
class SomeAvsQuery q where
|
||||
@ -763,7 +575,7 @@ guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
|
||||
let avsid = AvsPersonId nr in
|
||||
runDB (getBy $ UniqueUserAvsId avsid) >>= \case
|
||||
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
|
||||
Nothing -> catchAVS2message $ upsertAvsUserById avsid
|
||||
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
|
||||
| prefix=="AVSNO:" =
|
||||
runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
|
||||
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
|
||||
@ -797,15 +609,15 @@ upsertAvsUserByCard persNo = do
|
||||
-- NOTE: card validity might be outdated, so we must always check diretcly with avs and not within our DB!
|
||||
AvsResponsePerson adps <- avsQuery qry
|
||||
case Set.elems adps of
|
||||
[] -> throwM AvsPersonSearchEmpty
|
||||
[] -> return Nothing
|
||||
(_:_:_) -> throwM AvsPersonSearchAmbiguous
|
||||
[AvsDataPerson{avsPersonPersonID=api}] -> upsertAvsUserById api -- always triggers an update
|
||||
[AvsDataPerson{avsPersonPersonID=api}] -> Just <$> upsertAvsUserById api -- always triggers an update
|
||||
|
||||
|
||||
-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS licence status. Updates company, address, PinPassword
|
||||
-- Throws errors if the avsInterface in unavailable or new user would violate uniqueness constraints
|
||||
upsertAvsUserById0 :: AvsPersonId -> Handler UserId
|
||||
upsertAvsUserById0 api = do
|
||||
upsertAvsUserById :: AvsPersonId -> Handler UserId
|
||||
upsertAvsUserById api = do
|
||||
upd <- runDB (updateAvsUserByIds $ Set.singleton api)
|
||||
case Set.toList upd of
|
||||
[] -> createAvsUserById api
|
||||
|
||||
@ -8,11 +8,10 @@ import Import
|
||||
-- import Utils.PathPiece
|
||||
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Database.Persist.Postgresql
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
-- import qualified Data.Char as Char
|
||||
-- import qualified Data.Text as Text
|
||||
-- import Database.Persist.Postgresql
|
||||
|
||||
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
@ -45,52 +44,3 @@ addCompanySupervisors cid uid =
|
||||
]
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
-------------------
|
||||
-- DEPRECATED
|
||||
|
||||
|
||||
-- | Ensure that the given user is linked to the given company
|
||||
oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking
|
||||
oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do
|
||||
cid <- oldUpsertCompany cName cAddr
|
||||
void $ insertUnique $ UserCompany uid cid False False 1 False
|
||||
superVs <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] []
|
||||
upsertManyWhere [ UserSupervisor super uid reroute (Just cid) Nothing
|
||||
| Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs
|
||||
] [] [] []
|
||||
oldUpsertUserCompany uid _ _ =
|
||||
deleteWhere [ UserCompanyUser ==. uid ] -- maybe also delete company supervisors?
|
||||
|
||||
-- | Does not update company address for now
|
||||
-- TODO: update company address, maybe?!
|
||||
oldUpsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId
|
||||
oldUpsertCompany cName cAddr =
|
||||
let cName' = CI.mk cName in
|
||||
getBy (UniqueCompanyName cName') >>= \case
|
||||
Just ent -> return $ entityKey ent
|
||||
Nothing -> getBy (UniqueCompanySynonym cName') >>= \case
|
||||
Just ent -> return . CompanyKey . companySynonymCanonical $ entityVal ent
|
||||
Nothing -> do
|
||||
let cShort = oldCompanyShorthandFromName cName
|
||||
cShort' <- findShort cName' $ CI.mk cShort
|
||||
let compy = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented
|
||||
either entityKey id <$> insertBy compy
|
||||
where
|
||||
findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand
|
||||
findShort fna fsh = aux 0
|
||||
where
|
||||
aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in
|
||||
checkUnique (Company fna fsh' 0 False Nothing Nothing) >>= \case
|
||||
Nothing -> return fsh'
|
||||
_other -> aux (n+1)
|
||||
|
||||
-- | Just a cheap heuristic, needs manual intervention anyway
|
||||
oldCompanyShorthandFromName :: Text -> Text
|
||||
oldCompanyShorthandFromName cName =
|
||||
let cpats = splitCamel cName
|
||||
strip = Text.filter Char.isAlphaNum . Text.take 3
|
||||
spats = strip <$> cpats
|
||||
in Text.concat spats
|
||||
|
||||
@ -55,7 +55,7 @@ dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do
|
||||
return True
|
||||
_ -> -- unknown avsPersonId, attempt to create user
|
||||
return False
|
||||
unless ok $ void $ maybeCatchAll $ upsertAvsUserById apid
|
||||
unless ok $ void $ maybeCatchAll $ Just <$> upsertAvsUserById apid -- TOOD: needs thorough refactoring
|
||||
|
||||
|
||||
dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX
|
||||
|
||||
Loading…
Reference in New Issue
Block a user