chore(avs): change to secondary company (WIP) form missing
This commit is contained in:
parent
fdbaa3c9d4
commit
5944efcb86
@ -37,7 +37,8 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis
|
||||
AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an
|
||||
UsersCourseSchool: Bereich
|
||||
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
|
||||
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
|
||||
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!
|
||||
UserAvsSync: AVS-Synchronisieren
|
||||
UserLdapSync: LDAP-Synchronisieren
|
||||
AllUsersLdapSync: Alle LDAP-Synchronisieren
|
||||
UserHijack: Sitzung übernehmen
|
||||
UserAddSupervisor: Ansprechpartner hinzufügen
|
||||
UserSetSupervisor: Ansprechpartner ersetzen
|
||||
UserRemoveSupervisor: Alle Ansprechpartner entfernen
|
||||
UserIsSupervisor: Ist Ansprechpartner
|
||||
UserAvsSwitchCompany: Als Primärfirma verwenden
|
||||
AllUsersLdapSync: Alle LDAP-Synchronisieren
|
||||
AllUsersAvsSync: Alle AVS-Synchronisieren
|
||||
AuthKindLDAP: Fraport AG Kennung
|
||||
AuthKindPWHash: FRADrive Kennung
|
||||
AuthKindNoLogin: Kein Login möglich
|
||||
|
||||
@ -37,8 +37,9 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific
|
||||
AuthPWHashConfigured: User now logs in using their FRADrive specific account
|
||||
UsersCourseSchool: Department
|
||||
ActionNoUsersSelected: No users selected
|
||||
SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}.
|
||||
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}.
|
||||
SynchroniseAvsUserQueued n: Triggered forced AVS 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
|
||||
UserListTitle: Comprehensive list of users
|
||||
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!
|
||||
UserAvsSync: Synchronise with AVS
|
||||
UserLdapSync: Synchronise with LDAP
|
||||
AllUsersLdapSync: Synchronise all with LDAP
|
||||
UserHijack: Hijack session
|
||||
UserAddSupervisor: Add supervisor
|
||||
UserSetSupervisor: Replace supervisors
|
||||
UserRemoveSupervisor: Set to unsupervised
|
||||
UserIsSupervisor: Is supervisor
|
||||
UserAvsSwitchCompany: Use as primary company
|
||||
AllUsersLdapSync: Synchronise all with LDAP
|
||||
AllUsersAvsSync: Synchronise all with AVS
|
||||
AuthKindLDAP: Fraport AG account
|
||||
AuthKindPWHash: FRADrive account
|
||||
AuthKindNoLogin: No login
|
||||
|
||||
@ -27,7 +27,7 @@ import qualified Data.Map as Map
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Avs
|
||||
-- import Handler.Utils.Qualification
|
||||
|
||||
import Handler.Utils.Users (getUserPrimaryCompany)
|
||||
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
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 uuid = do
|
||||
uid <- decrypt uuid
|
||||
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
||||
mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
|
||||
mbStatus <- try $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
|
||||
-- mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed
|
||||
|
||||
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||
let warnBolt = messageTooltip msgWarningTooltip
|
||||
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}
|
||||
|]
|
||||
uid <- decrypt uuid
|
||||
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
||||
-- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
|
||||
let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
|
||||
-- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
|
||||
mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
|
||||
-- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
|
||||
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
|
||||
|
||||
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
|
||||
mkContactWgt warnBolt reqAvsNo AvsDataContact
|
||||
{ -- avsContactPersonID = _api
|
||||
avsContactPersonInfo = AvsPersonInfo{..}
|
||||
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
|
||||
} =
|
||||
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
|
||||
[whamlet|
|
||||
<section .profile>
|
||||
<dl .deflist.profile-dl>
|
||||
$if avsNoOk
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsPersonNo}
|
||||
<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}
|
||||
|]
|
||||
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||
let warnBolt = messageTooltip msgWarningTooltip
|
||||
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 compDict . 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}
|
||||
|]
|
||||
where
|
||||
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
|
||||
mkContactWgt warnBolt reqAvsNo AvsDataContact
|
||||
{ -- avsContactPersonID = _api
|
||||
avsContactPersonInfo = AvsPersonInfo{..}
|
||||
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
|
||||
} =
|
||||
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
|
||||
[whamlet|
|
||||
<section .profile>
|
||||
<dl .deflist.profile-dl>
|
||||
$if avsNoOk
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsPersonNo}
|
||||
<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 crds = do
|
||||
let hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds
|
||||
hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds
|
||||
[whamlet|
|
||||
<table>
|
||||
<thead>
|
||||
<th>_{MsgAvsCardNo}
|
||||
<th>_{MsgTableAvsCardValid}
|
||||
<th>_{MsgAvsCardColor}
|
||||
<th>_{MsgAvsCardAreas}
|
||||
<th>_{MsgTableCompany}
|
||||
$if hasIssueDate
|
||||
<th>_{MsgTableAvsCardIssueDate}
|
||||
$if hasValidToDate
|
||||
<th>_{MsgTableAvsCardValidTo}
|
||||
<tbody>
|
||||
$forall c <- crds
|
||||
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
|
||||
<tr>
|
||||
<td>
|
||||
#{tshowAvsFullCardNo (getFullCardNo c)}
|
||||
<td>
|
||||
#{boolSymbol avsDataValid}
|
||||
<td>
|
||||
_{avsDataCardColor}
|
||||
<td>
|
||||
$forall a <- avsDataCardAreas
|
||||
#{a} #
|
||||
<td>
|
||||
$maybe f <- avsDataFirm
|
||||
#{f}
|
||||
$if hasIssueDate
|
||||
<td>
|
||||
$maybe d <- avsDataIssueDate
|
||||
^{formatTimeW SelFormatDate d}
|
||||
$if hasValidToDate
|
||||
<td>
|
||||
$maybe d <- avsDataValidTo
|
||||
^{formatTimeW SelFormatDate d}
|
||||
|]
|
||||
mkCardsWgt :: (Maybe CompanyName, Map CompanyName CompanyId) -> Set AvsDataPersonCard -> Widget
|
||||
mkCardsWgt (primName, compDict) crds = do
|
||||
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
|
||||
hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds
|
||||
hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds
|
||||
[whamlet|
|
||||
<table>
|
||||
<thead>
|
||||
<th>_{MsgAvsCardNo}
|
||||
<th>_{MsgTableAvsCardValid}
|
||||
<th>_{MsgAvsCardColor}
|
||||
<th>_{MsgAvsCardAreas}
|
||||
$if hasIssueDate
|
||||
<th>_{MsgTableAvsCardIssueDate}
|
||||
$if hasValidToDate
|
||||
<th>_{MsgTableAvsCardValidTo}
|
||||
$if hasCompany
|
||||
<th>_{MsgTableCompany}
|
||||
<th>
|
||||
<tbody>
|
||||
$forall c <- crds
|
||||
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
|
||||
<tr>
|
||||
<td>
|
||||
#{tshowAvsFullCardNo (getFullCardNo c)}
|
||||
<td>
|
||||
#{boolSymbol avsDataValid}
|
||||
<td>
|
||||
_{avsDataCardColor}
|
||||
<td>
|
||||
$forall a <- avsDataCardAreas
|
||||
#{a} #
|
||||
$if hasIssueDate
|
||||
<td>
|
||||
$maybe d <- avsDataIssueDate
|
||||
^{formatTimeW SelFormatDate d}
|
||||
$if hasValidToDate
|
||||
<td>
|
||||
$maybe d <- avsDataValidTo
|
||||
^{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}
|
||||
|]
|
||||
|
||||
|
||||
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Handler.Users
|
||||
( module Handler.Users
|
||||
@ -25,8 +26,13 @@ import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
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 Handler.Profile (makeProfileData)
|
||||
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
@ -80,7 +86,7 @@ isActionSupervisor UserSetSupervisorData{} = True
|
||||
isActionSupervisor _ = False
|
||||
|
||||
|
||||
data AllUsersAction = AllUsersLdapSync
|
||||
data AllUsersAction = AllUsersLdapSync | AllUsersAvsSync
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
@ -373,7 +379,7 @@ postUsersR = do
|
||||
queueAvsUpdateByUID userSet Nothing
|
||||
addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
|
||||
redirectKeepGetParams UsersR
|
||||
(UserHijack, Set.minView -> Just (uid, _)) ->
|
||||
(UserHijack, Set.lookupMin -> Just uid) ->
|
||||
hijackUser uid >>= sendResponse
|
||||
(UserRemoveSupervisorData, userSet) -> do
|
||||
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
|
||||
@ -405,6 +411,20 @@ postUsersR = do
|
||||
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
|
||||
addMessageI Success MsgSynchroniseLdapAllUsersQueued
|
||||
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
|
||||
{ formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute UsersR
|
||||
|
||||
@ -23,6 +23,7 @@ module Handler.Utils.Avs
|
||||
, retrieveDifferingLicences, retrieveDifferingLicencesStatus
|
||||
, computeDifferingLicences
|
||||
-- , synchAvsLicences
|
||||
, queryAvsFullStatus
|
||||
-- , lookupAvsUser, lookupAvsUsers
|
||||
, AvsException(..)
|
||||
, updateReceivers
|
||||
@ -136,28 +137,35 @@ catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHan
|
||||
-- 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
|
||||
-- lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
-- AvsPersonId -> m (Maybe AvsDataPerson)
|
||||
-- lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
|
||||
-- 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 ) =>
|
||||
AvsPersonId -> m (Maybe AvsDataPerson)
|
||||
lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
|
||||
|
||||
-- -- | retrieves complete avs user records for given AvsPersonIds.
|
||||
-- -- Note that this requires several AVS-API queries, since
|
||||
-- -- - avsQueryPerson does not support querying an AvsPersonId directly
|
||||
-- -- - avsQueryStatus only provides limited information
|
||||
-- -- avsQuery is used to obtain all card numbers, which are then queried separately an merged
|
||||
-- -- May throw Servant.ClientError or AvsExceptions
|
||||
-- -- Does not write to our own DB!
|
||||
-- lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
-- Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
|
||||
-- lookupAvsUsers apis = do
|
||||
-- AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
|
||||
-- let forFoldlM = $(permuteFun [3,2,1]) foldlM
|
||||
-- forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
|
||||
-- forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
|
||||
-- AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
|
||||
-- return $ mergeByPersonId adps acc2
|
||||
-- | retrieves complete avs user records for given AvsPersonIds.
|
||||
-- Note that this requires several AVS-API queries, since
|
||||
-- - avsQueryPerson does not support querying an AvsPersonId directly
|
||||
-- - avsQueryStatus only provides limited information
|
||||
-- avsQuery is used to obtain all card numbers, which are then queried separately an merged
|
||||
-- May throw Servant.ClientError or AvsExceptions
|
||||
-- Does not write to our own DB!
|
||||
lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
|
||||
Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
|
||||
lookupAvsUsers apis = do
|
||||
AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
|
||||
let forFoldlM = $(permuteFun [3,2,1]) foldlM
|
||||
forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
|
||||
forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
|
||||
AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
|
||||
return $ mergeByPersonId adps acc2
|
||||
|
||||
|
||||
-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date
|
||||
|
||||
@ -76,6 +76,7 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
|
||||
assemble = Text.intercalate "."
|
||||
|
||||
|
||||
-- Note: Entity can be recovered, since CompanyShort is also the key
|
||||
getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany)
|
||||
getUserPrimaryCompany uid = entityVal <<$>>
|
||||
selectFirst [UserCompanyUser ==. uid]
|
||||
|
||||
@ -447,6 +447,9 @@ deriveJSON defaultOptions
|
||||
, rejectUnknownFields = False
|
||||
} ''AvsStatusPerson
|
||||
|
||||
makeLenses_ ''AvsStatusPerson
|
||||
|
||||
|
||||
data AvsDataPerson = AvsDataPerson
|
||||
{ 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
|
||||
|
||||
@ -9,8 +9,8 @@ import Import.NoModel
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Set as Set
|
||||
-- import qualified Data.Map as Map
|
||||
-- import qualified Data.Text as Text
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
@ -200,34 +200,34 @@ splitQuery rawQuery q
|
||||
-- compareBy f = compare `on` f a b
|
||||
-- -}
|
||||
|
||||
-- -- Merges several answers by AvsPersonId, preserving all AvsPersonCards
|
||||
-- mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
-- mergeByPersonId = flip $ Set.foldr aux
|
||||
-- where
|
||||
-- aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
-- aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
|
||||
-- Merges several answers by AvsPersonId, preserving all AvsPersonCards
|
||||
mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
mergeByPersonId = flip $ Set.foldr aux
|
||||
where
|
||||
aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
|
||||
|
||||
-- catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
-- catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
|
||||
catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
|
||||
|
||||
-- mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
-- mergeAvsDataPerson = Map.unionWithKey merger
|
||||
-- where
|
||||
-- merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
|
||||
-- merger api pa pb =
|
||||
-- let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
|
||||
-- pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
|
||||
-- in AvsDataPerson
|
||||
-- { avsPersonFirstName = pickBy' Text.length avsPersonFirstName
|
||||
-- , avsPersonLastName = pickBy' Text.length avsPersonLastName
|
||||
-- , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo
|
||||
-- , avsPersonPersonNo = pickBy' id avsPersonPersonNo
|
||||
-- , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
|
||||
-- , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb
|
||||
-- }
|
||||
mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
|
||||
mergeAvsDataPerson = Map.unionWithKey merger
|
||||
where
|
||||
merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
|
||||
merger api pa pb =
|
||||
let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
|
||||
pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
|
||||
in AvsDataPerson
|
||||
{ avsPersonFirstName = pickBy' Text.length avsPersonFirstName
|
||||
, avsPersonLastName = pickBy' Text.length avsPersonLastName
|
||||
, avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo
|
||||
, avsPersonPersonNo = pickBy' id avsPersonPersonNo
|
||||
, avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
|
||||
, avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb
|
||||
}
|
||||
|
||||
-- pickBy :: Ord b => (a -> b) -> a -> a -> a
|
||||
-- pickBy f x y | f x >= f y = x
|
||||
-- | otherwise = y
|
||||
pickBy :: Ord b => (a -> b) -> a -> a -> a
|
||||
pickBy f x y | f x >= f y = x
|
||||
| otherwise = y
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user