fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(avs): company upsert done

Browse Source 
updating supervision is still a todo
This commit is contained in:
Steffen Jost 2024-02-27 17:56:58 +01:00
parent c382be9325
commit 0b7175c26c
9 changed files with 157 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/company.model
View File

@ -7,7 +7,7 @@
Company
name CompanyName -- == (CI Text)
shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId A change to AvsId as primary key is too much work and not strictly necessary due to Uniqueness
avsId Int default=0 -- primary key from avs
avsId Int default=0 -- primary key from avs, use negative numbers for non-AVS companies
prefersPostal Bool default=false -- new company users prefers letters by post instead of email
postAddress StoredMarkup Maybe -- default company postal address, including company name
email UserEmail Maybe -- Case-insensitive generic company eMail address
@ -20,6 +20,6 @@ Company
-- TODO: a way to populate this table (manually)
CompanySynonym
synonym CompanyName
canonical CompanyShorthand OnDeleteCascade OnUpdateCascade
canonical CompanyShorthand OnDeleteCascade OnUpdateCascade -- DEPRECATED: should be CompanyId
UniqueCompanySynonym synonym
deriving Ord Eq Show Generic

2
models/users.model
View File

@ -97,7 +97,7 @@ UserSupervisor
supervisor UserId -- multiple supervisor per trainee possible
user UserId
rerouteNotifications Bool -- User can be his own supervisor to receive notifications as well
company CompanyId Maybe -- this supervisor was company default supervisor at time of entry
company CompanyId Maybe OnDeleteCascade OnUpdateCascade -- this supervisor was company default supervisor at time of entry
reason Text Maybe -- miscellanoues reason, e.g. Winterservice supervisision
UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
deriving Generic

2
src/Foundation/Yesod/Auth.hs
View File

@ -182,7 +182,7 @@ upsertCampusUser upsertMode ldapData = do
userDefaultConf <- getsYesod $ view _appUserDefaults
(newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
--TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
--TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.oldUpsertUserCompany, but this is called by upsertAvsUser already - conflict?
oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []

119
src/Handler/Utils/Avs.hs
View File

@ -51,6 +51,8 @@ import qualified Database.Esqueleto.Utils as E
import Servant.Client.Core.ClientError (ClientError)
import Utils.Mail (pickValidEmail)
import Handler.Utils.Profile (validPostAddressText)
--------------------
@ -472,7 +474,7 @@ upsertAvsUserById api = do
-- 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
upsertUserCompany uid mbCompany userFirmAddr
oldUpsertUserCompany uid mbCompany userFirmAddr
return mbUid
(Just (Entity _ UserAvs{userAvsUser=uid})
@ -500,7 +502,7 @@ upsertAvsUserById api = do
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
upsertUserCompany uid mbCompany userFirmAddr
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
@ -640,21 +642,66 @@ queryAvsCardNo crd = do
}
_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
_avsFirmPostAddress = to mkPost
where
mkPost AvsFirmInfo{..} =
let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
someAddr = fromMaybe "" $ asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
in if null someAddr
then Nothing
else Just $ plaintextToStoredMarkup $ avsFirmFirm <> Text.cons '\n' someAddr
_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
_avsFirmPrimaryEmail = to mkEmail
where
mkEmail afi =
let candidates = catMaybes
[ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
, afi ^. _avsFirmEMailSuperior
, afi ^. _avsFirmEMail
]
in pickValidEmail candidates -- should we return an invalid email rather than none?
-- | Not sure this is useful, since postal is ignored if there is no post address anyway
_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
_avsFirmPrefersPostal = to mkPostPref
where
mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting
-- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value,
-- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query
mkUpdate :: PersistEntity record => record -> iavs -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
mkUpdate usr newapi oldapi (CheckAvsUpdate up la)
mkUpdate ent newapi oldapi (CheckAvsUpdate up la)
| let newval = newapi ^. la
, let oldval = oldapi ^. la
, let usrval = getField up usr
, let entval = getField up ent
, oldval /= newval
, oldval == usrval
, oldval == entval
= Just (up =. newval)
mkUpdate _ _ _ _ = Nothing
mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
mkUpdateDirect dbv inp (CheckAvsUpdate up l)
| let newval = inp ^. l
, let entval = dbv ^. fieldLensVal up
, newval /= entval
= Just (up =. newval)
mkUpdateDirect _ _ _ = Nothing
-- | Unconditionally update a record through CheckAvsU
updateRecord :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> record
updateRecord dbv inp (CheckAvsUpdate up l) =
let newval = inp ^. l
lensRec = fieldLensVal up
in dbv & lensRec .~ newval
-- | Update given AvsPersonId by querying AVS for each; update only, no insertion!
updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
@ -693,20 +740,62 @@ updateAvsUserByIds apids = do
[ CheckAvsUpdate UserPostAddress $ _avsFirmAddress . to (Just . plaintextToStoredMarkup)
]
usr_ups = mcons eml_up $ frm_ups <> per_ups
-- TODO: update Company
-- cmp_up = let
-- cno_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirmNo)
-- cno_new = (oldAvsFirmInfo ^. _avsFirmFirmNo)
-- in
-- cmp_old = (oldAvsFirmInfo ^. _Just . _avsFirmFirm )
-- cmp_new = (oldAvsFirmInfo ^. _avsFirmFirm )
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
[ UserAvsLastSynch =. now
, UserAvsLastSynchError =. Nothing
, UserAvsLastPersonInfo =. Just newAvsPersonInfo
, UserAvsLastFirmInfo =. Just newAvsFirmInfo
]
lift $ update usrId usr_ups
]
_newCompanyId <- lift $ upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
-- TODO: if the company id has changed, update supervision too
lift $ update usrId usr_ups
lift $ update uaId avs_ups
return $ Set.singleton (apid, usrId)
-- | Query DB from given AvsFirmInfo. Guarantees that all Uniqueness-Constraints are checked
getAvsCompany :: AvsFirmInfo -> DB (Maybe (Entity Company))
getAvsCompany afi =
let compName :: CompanyName
compName = afi ^. _avsFirmFirm . re _CI
compShorthand :: CompanyShorthand
compShorthand = afi ^. _avsFirmAbbreviation . re _CI
compAvsId = afi ^. _avsFirmFirmNo
in firstJustM
[ getBy $ UniqueCompanyAvsId compAvsId
, getEntity $ CompanyKey compShorthand
, getBy $ UniqueCompanyName compName
]
upsertAvsCompany :: AvsFirmInfo -> Maybe AvsFirmInfo -> DB CompanyId
upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
mbFirmEnt <- getAvsCompany newAvsFirmInfo
case (mbFirmEnt, mbOldAvsFirmInfo) of
(Nothing, _) -> do -- insert new company
let upd = flip updateRecord newAvsFirmInfo
dmy = Company
{ companyName = newAvsFirmInfo ^. _avsFirmFirm . re _CI
, companyShorthand = newAvsFirmInfo ^. _avsFirmAbbreviation . re _CI
, companyAvsId = newAvsFirmInfo ^. _avsFirmFirmNo
, companyPrefersPostal = True
, companyPostAddress = Nothing
, companyEmail = Nothing
}
insert $ foldl' upd dmy firmInfo2company
(Just Entity{entityKey=firmid }, Nothing) -> do -- neither insert nor update; update impossible without old comparison values, since company could have been edited
$logWarnS "AVS" $ "upsertAvsCompany: neither insert nor update. Received existing company " <> (newAvsFirmInfo ^. _avsFirmFirm) <> " without old comparison value for update."
return firmid
(Just Entity{entityKey=firmid, entityVal=firm}, Just oldAvsFirmInfo) -> do -- possibly update existing company
let cmp_ups = mapMaybe (mkUpdate firm newAvsFirmInfo oldAvsFirmInfo) firmInfo2company
update firmid cmp_ups
return firmid
where
firmInfo2company =
[ CheckAvsUpdate CompanyName $ _avsFirmFirm . re _CI
, CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . re _CI
, CheckAvsUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade
-- , CheckAvsUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
, CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress
, CheckAvsUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
]

18
src/Handler/Utils/Company.hs
View File

@ -15,9 +15,9 @@ import qualified Data.Text as Text
import Database.Persist.Postgresql
-- | Ensure that the given user is linked to the given company
upsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking
upsertUserCompany uid (Just cName) cAddr | notNull cName = do
cid <- upsertCompany cName cAddr
oldUpsertUserCompany :: UserId -> Maybe Text -> Maybe StoredMarkup -> DB () -- TODO: needs reworking
oldUpsertUserCompany uid (Just cName) cAddr | notNull cName = do
cid <- oldUpsertCompany cName cAddr
void $ upsertBy (UniqueUserCompany uid cid)
(UserCompany uid cid False False)
[]
@ -25,20 +25,20 @@ upsertUserCompany uid (Just cName) cAddr | notNull cName = do
upsertManyWhere [ UserSupervisor super uid reroute (Just cid) Nothing
| Entity{entityVal=UserCompany{userCompanyUser=super, userCompanySupervisorReroute=reroute, userCompanySupervisor=True}} <- superVs
] [] [] []
upsertUserCompany uid _ _ =
oldUpsertUserCompany uid _ _ =
deleteWhere [ UserCompanyUser ==. uid ] -- maybe also delete company supervisors?
-- | Does not update company address for now
-- TODO: update company address, maybe?!
upsertCompany :: Text -> Maybe StoredMarkup -> DB CompanyId
upsertCompany cName cAddr =
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 = companyShorthandFromName cName
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
@ -52,8 +52,8 @@ upsertCompany cName cAddr =
_other -> aux (n+1)
-- | Just a cheap heuristic, needs manual intervention anyway
companyShorthandFromName :: Text -> Text
companyShorthandFromName cName =
oldCompanyShorthandFromName :: Text -> Text
oldCompanyShorthandFromName cName =
let cpats = splitCamel cName
strip = Text.filter Char.isAlphaNum . Text.take 3
spats = strip <$> cpats

20
src/Handler/Utils/Profile.hs
View File

@ -7,7 +7,7 @@
module Handler.Utils.Profile
( module Utils.Mail
, validDisplayName, checkDisplayName, fixDisplayName
, validPostAddress
, validPostAddress, validPostAddressText
, validFraportPersonalNumber
) where
@ -66,14 +66,20 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s
-- | Primitive postal address requires at least one alphabetic character, one digit and a line break
validPostAddress :: Maybe StoredMarkup -> Bool
validPostAddress (Just StoredMarkup {markupInput = addr})
| Just _ <- LT.find isLetter addr
, Just _ <- LT.find isNumber addr
-- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
, 1 < length (LT.lines addr)
= True
validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr
validPostAddress _ = False
validPostAddressText :: Text -> Bool
validPostAddressText = validPostAddressLazyText . LT.fromStrict
validPostAddressLazyText :: LT.Text -> Bool
validPostAddressLazyText addr
| Just _ <- LT.find isLetter addr
, Just _ <- LT.find isNumber addr
-- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
= 1 < length (LT.lines addr)
validPostAddressLazyText _ = False
validFraportPersonalNumber :: Maybe Text -> Bool
validFraportPersonalNumber Nothing = False
validFraportPersonalNumber (Just t)

18
src/Model/Types/Avs.hs
View File

@ -27,7 +27,6 @@ import qualified Data.Set as Set
import Data.Aeson
import Data.Aeson.Types
import Utils.Mail
{-
-- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
@ -602,7 +601,7 @@ derivePersistFieldJSON ''AvsFirmCommunication
data AvsFirmInfo = AvsFirmInfo
{ avsFirmFirm :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende!
, avsFirmFirmNo :: Int
, avsFirmFirmNo :: Int -- bei Verwendung ohne AVS: negative Zahl einsetzen
, avsFirmAbbreviation :: Text -- enthält manchmal Leerzeichen an Anfang oder Ende!
, avsFirmZIPCode :: Maybe Text
, avsFirmCity :: Maybe Text
@ -624,16 +623,11 @@ _avsFirmAddress = to mkAddr
commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
in textUnlines $ avsFirmFirm : catMaybes [commAddr <|> firmAddr]
_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
_avsFirmPrimaryEmail = to mkEmail
where
mkEmail afi =
let candidates = catMaybes
[ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
, afi ^. _avsFirmEMailSuperior
, afi ^. _avsFirmEMail
]
in pickValidEmail candidates -- should we return an invalid email rather than none?
-- Necessarily Moved to Handler.Utils.Avs due to dependencies:
-- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
-- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
-- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
instance FromJSON AvsFirmInfo where
parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo

14
src/Utils.hs
View File

@ -1017,18 +1017,22 @@ forMaybeM :: ( Monad m
) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b)
forMaybeM = flip mapMaybeM
{-
-- Takes computations returnings @Maybes@; tries each one in order.
-- | Only execute second action if the first does not produce a result
altM :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
altM ma mb = ma >>= \case
Nothing -> mb
res -> return res
-- Takes computations returnings @Maybe@; tries each one in order.
-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations
-- return @Nothing@.
-- Copied from GHC.Data.Maybe, which could not be imported somehow.
firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
firstJustsM = foldlM go Nothing
firstJustM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)
firstJustM = foldlM go Nothing
where
go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)
go Nothing action = action
go result@(Just _) _action = return result
-}
-- | Run the maybe computation repeatedly until the first Just is returned
-- or the number of maximum retries is exhausted.

14
src/Utils/DB.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -34,8 +34,18 @@ getFieldEnt :: PersistEntity record => EntityField record typ -> Entity record -
getFieldEnt = view . fieldLens
getField :: PersistEntity record => EntityField record typ -> record -> typ
getField = (. Entity (error "getField required key")) . getFieldEnt
getField = view . fieldLensVal
fieldLensVal :: PersistEntity record => EntityField record field -> Lens' record field
fieldLensVal f = entityLens . fieldLens f
where
entityLens :: Lens' record (Entity record)
entityLens = lens getVal setVal
getVal :: record -> Entity record
getVal = Entity (error "fieldLensVal unexpectectly required an entity key") -- this is safe, since the lens is only used locally
setVal :: record -> Entity record -> record
setVal _ = entityVal
emptyOrIn :: PersistField typ
=> E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)