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

chore(avs): upsertAvsUser now has a failsafe alternative

Browse Source
This commit is contained in:
Steffen Jost 2023-01-20 17:50:12 +01:00
parent 21fe05ea95
commit 3d51f2ebdb
7 changed files with 83 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/avs.model
View File

@ -25,7 +25,7 @@ UserAvs
-- Purpose of saving cards is to detect external changes in qualifications and postal addresses
UserAvsCard
personId AvsPersonId
cardNo AvsCardNo
cardNo AvsFullCardNo
card AvsDataPersonCard
lastSynch UTCTime
UniqueAvsCard cardNo

2
src/Handler/Admin/Avs.hs
View File

@ -155,7 +155,7 @@ postAdminAvsR = do
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
let procFormCrUsr fr = do
-- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- try $ upsertAvsUser fr
res <- try $ guessAvsUser fr
case res of
(Right (Just uid)) -> do
uuid :: CryptoUUIDUser <- encrypt uid

2
src/Handler/Course/ParticipantInvite.hs
View File

@ -151,7 +151,7 @@ postCAddUserR tid ssh csh = do
return $ AddUserRequest <$> auReqUsers <*> auReqTutorial
formResult usersToAdd $ \AddUserRequest{..} -> do
avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser auReqUsers
avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser auReqUsers
let (usersFound, usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
unless (null usersNotFound) $
let msgContent = [whamlet|

3
src/Handler/Users.hs
View File

@ -344,9 +344,10 @@ postUsersR = do
(UserRemoveSupervisorData, userSet) -> do
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
redirect UsersR
(act, usersSet)
| isActionSupervisor act -> do
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser $ getActionSupervisors act
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act
let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
users = Set.toList usersSet
nrSuperNotFound = length supersNotFound

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

@ -7,6 +7,7 @@
module Handler.Utils.Avs
( validQualification, validQualification'
, guessAvsUser
, upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, AvsLicenceDifferences(..)
@ -24,15 +25,15 @@ import Import
-- import qualified Database.Esqueleto.Legacy as E
import Utils.Avs
import Utils.Users
import qualified Data.Set as Set
import qualified Data.Map as Map
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 Auth.LDAP (ldapUserPrincipalName)
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
import Utils.Users
import Handler.Utils.Company
import Database.Esqueleto.Experimental ((:&)(..))
@ -288,13 +289,50 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld)
-}
-- | 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 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}] -> return $ Just uid
_ -> return Nothing
guessAvsUser someid = do
let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard
extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid
extractUidCard (Entity _ UserAvsCard{userAvsCardPersonId=avid}) = getBy $ UniqueUserAvsId avid
case discernAvsCardPersonalNo someid of
Just cid@(Left cardNo) ->
maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $
maybeM (return Nothing) extractUidCard $ getBy $ UniqueAvsCard cardNo
Just cid@(Right _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 (Right $ 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-Adress
-- | 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) = 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 (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}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ 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
@ -389,7 +427,7 @@ upsertAvsUserById api = do
forM_ avsPersonPersonCards $ -- save all cards for later
-- 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 (avsDataCardNo avsCard) avsCard now
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now
upsertUserCompany uid mbCompany
return mbUid
@ -407,15 +445,15 @@ upsertAvsUserById api = do
unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before
updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card
unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do
unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do
let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards
updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins]
[UserPinPassword =. userPin]
insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard now
insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now
upsertUserCompany uid mbCompany
forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard
{ userAvsCardPersonId = api
, userAvsCardCardNo = avsDataCardNo aCard
, userAvsCardCardNo = getFullCardNo aCard
, userAvsCardCard = aCard
, userAvsCardLastSynch = now
}

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

@ -140,8 +140,11 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where
type AvsVersionNo = Text -- always 1 digit
newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits
deriving (Eq, Ord, Show, Generic)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
instance E.SqlString AvsCardNo
deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField)
-- No longer needed:
-- deriving newtype (PersistField, PersistFieldSql)
-- instance E.SqlString AvsCardNo
-- AvsCardNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API
instance FromJSON AvsCardNo where
parseJSON x = AvsCardNo . normalizeAvsCardNo <$> parseJSON x
@ -156,7 +159,7 @@ instance Canonical AvsCardNo where
data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo }
deriving (Eq, Ord, Generic)
deriving (Eq, Ord, Generic, NFData)
tshowAvsFullCardNo :: AvsFullCardNo -> Text
tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo avsFullCardNo <> Text.cons '.' avsFullCardVersion
@ -170,6 +173,16 @@ readAvsFullCardNo (Text.span Char.isDigit -> (c, Text.uncons -> Just ('.',v)))
= Just $ AvsFullCardNo (AvsCardNo c) v
readAvsFullCardNo _ = Nothing
instance PersistField AvsFullCardNo where
toPersistValue = PersistText . tshowAvsFullCardNo
fromPersistValue (PersistText t)
| Just afc <- readAvsFullCardNo t = Right afc
| otherwise = Left $ "Encoding of AvsFullCardNo is invalid: " <> t
fromPersistValue other = Left $ "Encoding of AvsFullCardNo with invalid type: " <> tshow other
instance PersistFieldSql AvsFullCardNo where
sqlType _ = SqlString
discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point
discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv))
| Text.null pv

13
src/Utils.hs
View File

@ -1022,6 +1022,19 @@ actRight (Right y) f = f y
-- Exception --
---------------
-- maybeCatchAll :: MonadCatch m => m a -> m (Maybe a)
-- maybeCatchAll act = catch (Just <$> act) ignore
-- where
-- ignore :: Monad m => SomeException -> m (Maybe a)
-- ignore _ = return Nothing
-- | Ignore all errors by returning Nothing. (Not sure if this function is a good idea)
maybeCatchAll :: MonadCatch m => m (Maybe a) -> m (Maybe a)
maybeCatchAll act = catch act ignore
where
ignore :: Monad m => SomeException -> m (Maybe a)
ignore _ = return Nothing
maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
maybeExceptT err act = lift act >>= maybe (throwE err) return