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

chore(avs): change to secondary company (WIP) form missing

Browse Source
This commit is contained in:
Steffen Jost 2024-05-02 17:28:59 +02:00
parent fdbaa3c9d4
commit 5944efcb86
8 changed files with 240 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -37,7 +37,8 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis
AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an
UsersCourseSchool: Bereich UsersCourseSchool: Bereich
ActionNoUsersSelected: Keine Benutzer:innen ausgewählt ActionNoUsersSelected: Keine Benutzer:innen ausgewählt
SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen
SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
UserListTitle: Komprehensive Benutzerliste UserListTitle: Komprehensive Benutzerliste
@ -89,12 +90,14 @@ NewPasswordLink: Neues Passwort setzen
UserAccountDeleteWarning: Achtung, dies löscht den kompletten Benutzer/die komplette Benutzerin unwiderruflich und mit allen assoziierten Daten aus der Datenbank. Prüfungsdaten müssen jedoch langfristig gespeichert bleiben! UserAccountDeleteWarning: Achtung, dies löscht den kompletten Benutzer/die komplette Benutzerin unwiderruflich und mit allen assoziierten Daten aus der Datenbank. Prüfungsdaten müssen jedoch langfristig gespeichert bleiben!
UserAvsSync: AVS-Synchronisieren UserAvsSync: AVS-Synchronisieren
UserLdapSync: LDAP-Synchronisieren UserLdapSync: LDAP-Synchronisieren
AllUsersLdapSync: Alle LDAP-Synchronisieren
UserHijack: Sitzung übernehmen UserHijack: Sitzung übernehmen
UserAddSupervisor: Ansprechpartner hinzufügen UserAddSupervisor: Ansprechpartner hinzufügen
UserSetSupervisor: Ansprechpartner ersetzen UserSetSupervisor: Ansprechpartner ersetzen
UserRemoveSupervisor: Alle Ansprechpartner entfernen UserRemoveSupervisor: Alle Ansprechpartner entfernen
UserIsSupervisor: Ist Ansprechpartner UserIsSupervisor: Ist Ansprechpartner
UserAvsSwitchCompany: Als Primärfirma verwenden
AllUsersLdapSync: Alle LDAP-Synchronisieren
AllUsersAvsSync: Alle AVS-Synchronisieren
AuthKindLDAP: Fraport AG Kennung AuthKindLDAP: Fraport AG Kennung
AuthKindPWHash: FRADrive Kennung AuthKindPWHash: FRADrive Kennung
AuthKindNoLogin: Kein Login möglich AuthKindNoLogin: Kein Login möglich

9
messages/uniworx/categories/user/en-eu.msg
View File

@ -37,8 +37,9 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific
AuthPWHashConfigured: User now logs in using their FRADrive specific account AuthPWHashConfigured: User now logs in using their FRADrive specific account
UsersCourseSchool: Department UsersCourseSchool: Department
ActionNoUsersSelected: No users selected ActionNoUsersSelected: No users selected
SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}. SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}. SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}
SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
UserListTitle: Comprehensive list of users UserListTitle: Comprehensive list of users
AccessRightsSaved: Successfully updated permissions AccessRightsSaved: Successfully updated permissions
@ -89,12 +90,14 @@ NewPasswordLink: Set password
UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term! UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term!
UserAvsSync: Synchronise with AVS UserAvsSync: Synchronise with AVS
UserLdapSync: Synchronise with LDAP UserLdapSync: Synchronise with LDAP
AllUsersLdapSync: Synchronise all with LDAP
UserHijack: Hijack session UserHijack: Hijack session
UserAddSupervisor: Add supervisor UserAddSupervisor: Add supervisor
UserSetSupervisor: Replace supervisors UserSetSupervisor: Replace supervisors
UserRemoveSupervisor: Set to unsupervised UserRemoveSupervisor: Set to unsupervised
UserIsSupervisor: Is supervisor UserIsSupervisor: Is supervisor
UserAvsSwitchCompany: Use as primary company
AllUsersLdapSync: Synchronise all with LDAP
AllUsersAvsSync: Synchronise all with AVS
AuthKindLDAP: Fraport AG account AuthKindLDAP: Fraport AG account
AuthKindPWHash: FRADrive account AuthKindPWHash: FRADrive account
AuthKindNoLogin: No login AuthKindNoLogin: No login

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

@ -27,7 +27,7 @@ import qualified Data.Map as Map
import Handler.Utils import Handler.Utils
import Handler.Utils.Avs import Handler.Utils.Avs
-- import Handler.Utils.Qualification -- import Handler.Utils.Qualification
import Handler.Utils.Users (getUserPrimaryCompany)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
@ -676,126 +676,157 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
data UserAvsAction = UserAvsSwitchCompany
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''UserAvsAction id
data UserAvsActionData = UserAvsSwitchCompanyData { getAvsUser :: UserId, getAvsCompany :: CompanyId }
deriving (Eq, Ord, Read, Show, Generic)
getAdminAvsUserR :: CryptoUUIDUser -> Handler Html getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR uuid = do getAdminAvsUserR uuid = do
uid <- decrypt uuid uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId -- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
mbStatus <- try $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
-- mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
msgWarningTooltip <- messageI Warning MsgMessageWarning -- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
let warnBolt = messageTooltip msgWarningTooltip mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson
let contactWgt = case mbContact of
Left err -> exceptionWgt err
Right (AvsResponseContact adcs) -> do
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
mconcat cs
cardsWgt = case mbStatus of
Left err -> exceptionWgt err
Right (AvsResponseStatus asts) -> do
let cs = mkCardsWgt . avsStatusPersonCardStatus <$> toList asts
mconcat cs
-- cardsWgt = case mbDataPerson of
-- Nothing -> mempty
-- Just AvsDataPerson{avsPersonPersonCards=crds} -> mkCardsWgt crds
[whamlet|
<p>
Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten:
<p>
^{contactWgt}
<p>
^{cardsWgt}
|]
compDict <- runDB $ do
mbPrimeComp <- getUserPrimaryCompany uid
let (primeName, fltrPrimary) = maybeEmpty mbPrimeComp $ \Company{companyName=pName, companyShorthand=pShort} -> (pName, [CompanyShorthand !=. pShort])
compsUsed :: [Text] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
fltrCmps = (CompanyName <-. compsUsed) : fltrPrimary
comps <- selectList fltrCmps [Asc CompanyName] -- company name is unique
return (primeName, Map.fromAscList [(cname,cid) | (Entity{entityKey=cid, entityVal=Company{companyName=cname}}) <- comps])
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget msgWarningTooltip <- messageI Warning MsgMessageWarning
mkContactWgt warnBolt reqAvsNo AvsDataContact let warnBolt = messageTooltip msgWarningTooltip
{ -- avsContactPersonID = _api heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
avsContactPersonInfo = AvsPersonInfo{..} siteLayout heading $ do
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName } setTitle $ toHtml $ show userAvsNoPerson
} = let contactWgt = case mbContact of
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in Left err -> exceptionWgt err
[whamlet| Right (AvsResponseContact adcs) -> do
<section .profile> let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
<dl .deflist.profile-dl> mconcat cs
$if avsNoOk cardsWgt = case mbStatus of
<dt .deflist__dt> Left err -> exceptionWgt err
_{MsgAvsPersonNo} Right (AvsResponseStatus asts) -> do
<dd .deflist__dd> let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
#{avsInfoPersonNo} mconcat cs
^{warnBolt} -- cardsWgt = case mbDataPerson of
_{MsgAvsPersonNoMismatch} -- Nothing -> mempty
<dt .deflist__dt> -- Just AvsDataPerson{avsPersonPersonCards=crds} -> mkCardsWgt crds
_{MsgAvsLastName} [whamlet|
<dd .deflist__dd> <p>
#{avsInfoLastName} Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten:
<dt .deflist__dt> <p>
_{MsgAvsFirstName} ^{contactWgt}
<dd .deflist__dd> <p>
#{avsInfoFirstName} ^{cardsWgt}
<dt .deflist__dt> |]
_{MsgAvsPrimaryCompany} where
<dd .deflist__dd> mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
#{firmName} mkContactWgt warnBolt reqAvsNo AvsDataContact
$maybe bday <- avsInfoDateOfBirth { -- avsContactPersonID = _api
<dt .deflist__dt> avsContactPersonInfo = AvsPersonInfo{..}
_{MsgAdminUserBirthday} , avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
<dd .deflist__dd> } =
^{formatTimeW SelFormatDate bday} let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
<dt .deflist__dt> [whamlet|
_{MsgAvsLicence} <section .profile>
<dd .deflist__dd> <dl .deflist.profile-dl>
$maybe licence <- parseAvsLicence avsInfoRampLicence $if avsNoOk
_{licence} <dt .deflist__dt>
$nothing _{MsgAvsPersonNo}
_{MsgAvsNoLicenceGuest} <dd .deflist__dd>
|] #{avsInfoPersonNo}
^{warnBolt}
_{MsgAvsPersonNoMismatch}
<dt .deflist__dt>
_{MsgAvsLastName}
<dd .deflist__dd>
#{avsInfoLastName}
<dt .deflist__dt>
_{MsgAvsFirstName}
<dd .deflist__dd>
#{avsInfoFirstName}
<dt .deflist__dt>
_{MsgAvsPrimaryCompany}
<dd .deflist__dd>
#{firmName}
$maybe bday <- avsInfoDateOfBirth
<dt .deflist__dt>
_{MsgAdminUserBirthday}
<dd .deflist__dd>
^{formatTimeW SelFormatDate bday}
<dt .deflist__dt>
_{MsgAvsLicence}
<dd .deflist__dd>
$maybe licence <- parseAvsLicence avsInfoRampLicence
_{licence}
$nothing
_{MsgAvsNoLicenceGuest}
|]
mkCardsWgt :: Set AvsDataPersonCard -> Widget mkCardsWgt :: (Maybe CompanyName, Map CompanyName CompanyId) -> Set AvsDataPersonCard -> Widget
mkCardsWgt crds = do mkCardsWgt (primName, compDict) crds = do
let hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does
hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds
[whamlet| hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds
<table> [whamlet|
<thead> <table>
<th>_{MsgAvsCardNo} <thead>
<th>_{MsgTableAvsCardValid} <th>_{MsgAvsCardNo}
<th>_{MsgAvsCardColor} <th>_{MsgTableAvsCardValid}
<th>_{MsgAvsCardAreas} <th>_{MsgAvsCardColor}
<th>_{MsgTableCompany} <th>_{MsgAvsCardAreas}
$if hasIssueDate $if hasIssueDate
<th>_{MsgTableAvsCardIssueDate} <th>_{MsgTableAvsCardIssueDate}
$if hasValidToDate $if hasValidToDate
<th>_{MsgTableAvsCardValidTo} <th>_{MsgTableAvsCardValidTo}
<tbody> $if hasCompany
$forall c <- crds <th>_{MsgTableCompany}
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c <th>
<tr> <tbody>
<td> $forall c <- crds
#{tshowAvsFullCardNo (getFullCardNo c)} $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
<td> <tr>
#{boolSymbol avsDataValid} <td>
<td> #{tshowAvsFullCardNo (getFullCardNo c)}
_{avsDataCardColor} <td>
<td> #{boolSymbol avsDataValid}
$forall a <- avsDataCardAreas <td>
#{a} # _{avsDataCardColor}
<td> <td>
$maybe f <- avsDataFirm $forall a <- avsDataCardAreas
#{f} #{a} #
$if hasIssueDate $if hasIssueDate
<td> <td>
$maybe d <- avsDataIssueDate $maybe d <- avsDataIssueDate
^{formatTimeW SelFormatDate d} ^{formatTimeW SelFormatDate d}
$if hasValidToDate $if hasValidToDate
<td> <td>
$maybe d <- avsDataValidTo $maybe d <- avsDataValidTo
^{formatTimeW SelFormatDate d} ^{formatTimeW SelFormatDate d}
|] $if hasCompany
<td>
$maybe f <- avsDataFirm
#{f}
<td>
$maybe f <- avsDataFirm
$if (primName == stripCI f)
current primary company
$else
$maybe cid <- compDict f
switch company to #{tshow cid}
|]

24
src/Handler/Users.hs
View File

@ -3,6 +3,7 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeApplications #-}
module Handler.Users module Handler.Users
( module Handler.Users ( module Handler.Users
@ -25,8 +26,13 @@ import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Handler.Profile (makeProfileData) import Handler.Profile (makeProfileData)
import qualified Yesod.Auth.Util.PasswordStore as PWStore import qualified Yesod.Auth.Util.PasswordStore as PWStore
@ -80,7 +86,7 @@ isActionSupervisor UserSetSupervisorData{} = True
isActionSupervisor _ = False isActionSupervisor _ = False
data AllUsersAction = AllUsersLdapSync data AllUsersAction = AllUsersLdapSync | AllUsersAvsSync
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)
@ -373,7 +379,7 @@ postUsersR = do
queueAvsUpdateByUID userSet Nothing queueAvsUpdateByUID userSet Nothing
addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
redirectKeepGetParams UsersR redirectKeepGetParams UsersR
(UserHijack, Set.minView -> Just (uid, _)) -> (UserHijack, Set.lookupMin -> Just uid) ->
hijackUser uid >>= sendResponse hijackUser uid >>= sendResponse
(UserRemoveSupervisorData, userSet) -> do (UserRemoveSupervisorData, userSet) -> do
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
@ -405,6 +411,20 @@ postUsersR = do
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
addMessageI Success MsgSynchroniseLdapAllUsersQueued addMessageI Success MsgSynchroniseLdapAllUsersQueued
redirect UsersR redirect UsersR
AllUsersAvsSync -> do
nowaday <- liftIO getCurrentTime <&> utctDay
n <- runDB $ Ex.insertSelectCount $ do
usr <- Ex.from $ Ex.table @User
return (AvsSync
Ex.<# (usr Ex.^. UserId)
Ex.<&> E.now_
-- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
Ex.<&> E.justVal nowaday
)
queueJob' JobSynchroniseAvsQueue
addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n
redirect UsersR
let allUsersWgt' = wrapForm allUsersWgt def let allUsersWgt' = wrapForm allUsersWgt def
{ formSubmit = FormNoSubmit { formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute UsersR , formAction = Just $ SomeRoute UsersR

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

@ -23,6 +23,7 @@ module Handler.Utils.Avs
, retrieveDifferingLicences, retrieveDifferingLicencesStatus , retrieveDifferingLicences, retrieveDifferingLicencesStatus
, computeDifferingLicences , computeDifferingLicences
-- , synchAvsLicences -- , synchAvsLicences
, queryAvsFullStatus
-- , lookupAvsUser, lookupAvsUsers -- , lookupAvsUser, lookupAvsUsers
, AvsException(..) , AvsException(..)
, updateReceivers , updateReceivers
@ -136,28 +137,35 @@ catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHan
-- AVS Handlers -- -- AVS Handlers --
------------------ ------------------
-- convenience wrapper for easy replacement with true status query
queryAvsFullStatus :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m AvsResponseStatus
queryAvsFullStatus api =
lookupAvsUser api <&> \case
Just AvsDataPerson{avsPersonPersonCards=cards}
| notNull cards -> AvsResponseStatus $ Set.singleton $ AvsStatusPerson api cards
_otherwise -> AvsResponseStatus mempty
-- TODO: delete deprecated Utility Functions from Utils.Avs as well -- TODO: delete deprecated Utility Functions from Utils.Avs as well -- still needed, since avsStatusQuery does not deliver company names tied to cards
-- lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
-- AvsPersonId -> m (Maybe AvsDataPerson) AvsPersonId -> m (Maybe AvsDataPerson)
-- lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
-- -- | retrieves complete avs user records for given AvsPersonIds. -- | retrieves complete avs user records for given AvsPersonIds.
-- -- Note that this requires several AVS-API queries, since -- Note that this requires several AVS-API queries, since
-- -- - avsQueryPerson does not support querying an AvsPersonId directly -- - avsQueryPerson does not support querying an AvsPersonId directly
-- -- - avsQueryStatus only provides limited information -- - avsQueryStatus only provides limited information
-- -- avsQuery is used to obtain all card numbers, which are then queried separately an merged -- avsQuery is used to obtain all card numbers, which are then queried separately an merged
-- -- May throw Servant.ClientError or AvsExceptions -- May throw Servant.ClientError or AvsExceptions
-- -- Does not write to our own DB! -- Does not write to our own DB!
-- lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
-- Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson) Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
-- lookupAvsUsers apis = do lookupAvsUsers apis = do
-- AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
-- let forFoldlM = $(permuteFun [3,2,1]) foldlM let forFoldlM = $(permuteFun [3,2,1]) foldlM
-- forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
-- forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
-- AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo} AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
-- return $ mergeByPersonId adps acc2 return $ mergeByPersonId adps acc2
-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date -- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date

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

@ -76,6 +76,7 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
assemble = Text.intercalate "." assemble = Text.intercalate "."
-- Note: Entity can be recovered, since CompanyShort is also the key
getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany) getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany)
getUserPrimaryCompany uid = entityVal <<$>> getUserPrimaryCompany uid = entityVal <<$>>
selectFirst [UserCompanyUser ==. uid] selectFirst [UserCompanyUser ==. uid]

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

@ -447,6 +447,9 @@ deriveJSON defaultOptions
, rejectUnknownFields = False , rejectUnknownFields = False
} ''AvsStatusPerson } ''AvsStatusPerson
makeLenses_ ''AvsStatusPerson
data AvsDataPerson = AvsDataPerson data AvsDataPerson = AvsDataPerson
{ avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces { avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
, avsPersonLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces , avsPersonLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces

56
src/Utils/Avs.hs
View File

@ -9,8 +9,8 @@ import Import.NoModel
import Utils.Lens import Utils.Lens
import qualified Data.Set as Set import qualified Data.Set as Set
-- import qualified Data.Map as Map import qualified Data.Map as Map
-- import qualified Data.Text as Text import qualified Data.Text as Text
import Servant import Servant
import Servant.Client import Servant.Client
@ -200,34 +200,34 @@ splitQuery rawQuery q
-- compareBy f = compare `on` f a b -- compareBy f = compare `on` f a b
-- -} -- -}
-- -- Merges several answers by AvsPersonId, preserving all AvsPersonCards -- Merges several answers by AvsPersonId, preserving all AvsPersonCards
-- mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-- mergeByPersonId = flip $ Set.foldr aux mergeByPersonId = flip $ Set.foldr aux
-- where where
-- aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-- aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
-- catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
-- catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
-- mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
-- mergeAvsDataPerson = Map.unionWithKey merger mergeAvsDataPerson = Map.unionWithKey merger
-- where where
-- merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
-- merger api pa pb = merger api pa pb =
-- let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
-- pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
-- in AvsDataPerson in AvsDataPerson
-- { avsPersonFirstName = pickBy' Text.length avsPersonFirstName { avsPersonFirstName = pickBy' Text.length avsPersonFirstName
-- , avsPersonLastName = pickBy' Text.length avsPersonLastName , avsPersonLastName = pickBy' Text.length avsPersonLastName
-- , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo
-- , avsPersonPersonNo = pickBy' id avsPersonPersonNo , avsPersonPersonNo = pickBy' id avsPersonPersonNo
-- , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
-- , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb
-- } }
-- pickBy :: Ord b => (a -> b) -> a -> a -> a pickBy :: Ord b => (a -> b) -> a -> a -> a
-- pickBy f x y | f x >= f y = x pickBy f x y | f x >= f y = x
-- | otherwise = y | otherwise = y