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

chore(avs): upsertAvsUserById completed

Browse Source
This commit is contained in:
Steffen Jost 2022-11-22 17:39:19 +01:00
parent 0b2fa2c197
commit 17b3341bba
8 changed files with 100 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
models/users.model
View File

@ -84,10 +84,10 @@ UserGroupMember
UniqueUserGroupMember group user
deriving Generic
UserCompany
company CompanyId
user UserId
company CompanyId
supervisor Bool -- is this user a company supervisor?
UniqueCompanyUser company user
UniqueUserCompany user -- only one company per user is currently allowed
deriving Generic
UserSupervisor
supervisor UserId -- multiple supervisor per trainee possible

2
src/Handler/Profile.hs
View File

@ -1023,7 +1023,7 @@ mkQualificationsTable =
, dbtProj = dbtProjId
, dbtColonnade = mconcat
[ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
) $ qualificationBlockedCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserBlockedDue )
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )

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

@ -117,12 +117,8 @@ checkLicences = do
upsertAvsUser :: Text -> Handler (Maybe UserId)
-- upsertAvsUser (readAvsFullCardNo -> Just afcn) = upsertAvsUserByCard afcn
-- upsertAvsUser someid
-- | Just avsid <- discernAvsIds someid
-- = upsertAvsUserByCard $ over _Right (const someid) avsid -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot discern, but the latter is much more likely and useful!
upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid
upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary now
upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now
{- maybe this code helps?
upsRes :: Either CampusUserConversionException (Entity User)
<- try $ upsertCampusUserByOther persNo
@ -132,7 +128,27 @@ upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eM
-}
-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created.
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible.
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
upsertAvsUserByCard persNo = do
let qry = case persNo of
Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
Right 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=appi}] -> do
mbuid <- runDB $ getBy $ UniqueUserAvsId appi
case mbuid of
(Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
Nothing -> upsertAvsUserById appi
-- | 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
@ -150,16 +166,19 @@ upsertAvsUserById api = do
upsRes :: Either CampusUserConversionException (Entity User)
<- try $ upsertCampusUserByCn persNo
case upsRes of
Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid
Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid -- pin/addr are updated in next step anyway
_other -> return mbuid -- ==Nothing -- user could not be created somehow
_other -> return mbuid
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{..}) -> do -- No LDAP User, but found in AVS; create user
(Nothing, Just AvsDataPerson{..}) -> do -- No LDAP User, but found in AVS; create new user
let firmAddress = guessLicenceAddress avsPersonPersonCards
mbCompany = firmAddress ^? _Just . _1 . _Just
bestCard = Set.lookupMax avsPersonPersonCards
fakeIdent = CI.mk $ tshow api
userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
addrCard = firmAddress ^? _Just . _3
pinCard = Set.lookupMax avsPersonPersonCards
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
fakeIdent = CI.mk $ "AVSID:" <> tshow api
newUsr = AdminUserForm
{ aufTitle = Nothing
, aufFirstName = avsPersonFirstName
@ -172,53 +191,60 @@ upsertAvsUserById api = do
, aufTelephone = Nothing
, aufFPersonalNumber = avsPersonInternalPersonalNo
, aufFDepartment = Nothing
, aufPostAddress = plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
, aufPostAddress = userFirmAddr
, aufPrefersPostal = isJust firmAddress
, aufPinPassword = tshowAvsFullCardNo . getFullCardNo <$> bestCard
, aufPinPassword = userPin
, aufEmail = fakeIdent -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
, aufIdent = fakeIdent -- use AvsPersonId instead
, aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known
}
mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
case mbUid of
Just uid -> runDB $ do
now <- liftIO getCurrentTime
insert_ $ UserAvs avsPersonPersonID uid
-- forM_ avsPersonPersonCards $ -- save all cards for later
forM_ bestCard $ -- only save the card used to the postal address
\avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now
case mbCompany of
Just cpy -> do
cid <- upsertCompany cpy
insert_ $ UserCompany cid uid False
_ -> return ()
_ -> return ()
whenIsJust mbUid $ \uid -> runDB $ do
now <- liftIO getCurrentTime
insert_ $ UserAvs avsPersonPersonID uid
-- 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
upsertUserCompany uid mbCompany
return mbUid
(Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates
error "TODO" -- CONTINUE HERE
(Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword
let firmAddress = guessLicenceAddress avsPersonPersonCards
mbCompany = firmAddress ^? _Just . _1 . _Just
userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress
addrCard = firmAddress ^? _Just . _3
pinCard = Set.lookupMax avsPersonPersonCards
userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard
runDB $ do
now <- liftIO getCurrentTime
upsertUserCompany uid mbCompany
whenIsJust addrCard $ \aCard ->
getBy (UniqueAvsCard $ avsDataCardNo aCard) >>= \case
(Just (Entity uac UserAvsCard{..})) | aCard == userAvsCardCard -> -- address seen before, no change
update uac [UserAvsCardLastSynch =. now]
_ -> do -- possibly new address data
void $ upsert UserAvsCard
{ userAvsCardPersonId = api
, userAvsCardCardNo = avsDataCardNo aCard
, userAvsCardCard = aCard
, userAvsCardLastSynch= now
}
[ UserAvsCardCard =. aCard
, UserAvsCardLastSynch =. now
]
when (isJust userFirmAddr) $ updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr]
whenIsJust pinCard $ \pCard ->
unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do
-- update pin, but only if it was unset or set to the value of an old card
oldCards <- selectList [UserAvsCardPersonId ==. api] []
let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards
updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins]
[UserPinPassword =. userPin]
insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard now
return $ Just uid
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible.
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
--upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
-- upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m )
upsertAvsUserByCard ::
Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?!
upsertAvsUserByCard persNo = do
let qry = case persNo of
Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion }
Right 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=appi}] -> do
mbuid <- runDB $ getBy $ UniqueUserAvsId appi
case mbuid of
(Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau
Nothing -> upsertAvsUserById appi

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

@ -13,6 +13,15 @@ import qualified Data.Char as Char
import qualified Data.Text as Text
-- | Ensure that the given user is linked to the given company
upsertUserCompany :: UserId -> Maybe Text -> DB ()
upsertUserCompany uid (Just cName) | notNull cName = do
cid <- upsertCompany cName
void $ upsertBy (UniqueUserCompany uid)
(UserCompany uid cid False)
[UserCompanyCompany =. cid, UserCompanySupervisor =. False]
upsertUserCompany uid _ = deleteBy (UniqueUserCompany uid)
upsertCompany :: Text -> DB CompanyId
upsertCompany cName =
let cName' = CI.mk cName in

6
src/Handler/Utils/Table/Cells.hs
View File

@ -272,10 +272,14 @@ courseCell Course{..} = anchorCell link name `mappend` desc
|]
qualificationCell :: IsDBTable m a => Qualification -> DBCell m a
qualificationCell Qualification{..} = anchorCell link name <> desc
qualificationCell Qualification{..} = anchorCell link name
where
link = QualificationR qualificationSchool qualificationShorthand
name = citext2widget qualificationName
qualificationDescrCell :: IsDBTable m a => Qualification -> DBCell m a
qualificationDescrCell q@Qualification{..} = qualificationCell q <> desc
where
desc = case qualificationDescription of
Nothing -> mempty
(Just descr) -> spacerCell <> markupCellLargeModal descr

6
src/Handler/Utils/Users.hs
View File

@ -910,12 +910,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
-- Companies, in conflict, keep the newUser-Company as is
E.insertSelectWithConflict
UniqueCompanyUser
UniqueUserCompany
(E.from $ \userCompany -> do
E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
return $ UserCompany
E.<# (userCompany E.^. UserCompanyCompany)
E.<&> E.val newUserId
E.<# E.val newUserId
E.<&> (userCompany E.^. UserCompanyCompany)
E.<&> (userCompany E.^. UserCompanySupervisor)
)
(\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )

3
src/Utils.hs
View File

@ -623,7 +623,8 @@ mTuple = liftA2 (,)
-- Lists --
-----------
-- notNull = not . null
notNull :: MonoFoldable mono => mono -> Bool
notNull = not . null
headDef :: a -> [a] -> a
headDef _ (h:_) = h

4
test/Database/Fill.hs
View File

@ -113,7 +113,7 @@ fillDb = do
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Nothing
, userCompanyPersonalNumber = Just "00000"
, userCompanyDepartment = Nothing
, userPinPassword = Nothing
, userPostAddress = Nothing
@ -271,7 +271,7 @@ fillDb = do
, userShowSex = userDefaultShowSex
, userTelephone = Nothing
, userMobile = Nothing
, userCompanyPersonalNumber = Nothing
, userCompanyPersonalNumber = Just "12345"
, userCompanyDepartment = Nothing
, userPinPassword = Nothing
, userPostAddress = Nothing