- Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten: -
- ^{contactWgt} -
- ^{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|
-
+ Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten:
+
+ ^{contactWgt}
+
+ ^{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|
+
- $if avsNoOk
-
+ $if avsNoOk
+
-
-
_{MsgAvsCardNo}
- _{MsgTableAvsCardValid}
- _{MsgAvsCardColor}
- _{MsgAvsCardAreas}
- _{MsgTableCompany}
- $if hasIssueDate
- _{MsgTableAvsCardIssueDate}
- $if hasValidToDate
- _{MsgTableAvsCardValidTo}
-
- $forall c <- crds
- $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
-
-
- #{tshowAvsFullCardNo (getFullCardNo c)}
-
- #{boolSymbol avsDataValid}
-
- _{avsDataCardColor}
-
- $forall a <- avsDataCardAreas
- #{a} #
-
- $maybe f <- avsDataFirm
- #{f}
- $if hasIssueDate
-
- $maybe d <- avsDataIssueDate
- ^{formatTimeW SelFormatDate d}
- $if hasValidToDate
-
- $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|
+
+
+
_{MsgAvsCardNo}
+ _{MsgTableAvsCardValid}
+ _{MsgAvsCardColor}
+ _{MsgAvsCardAreas}
+ $if hasIssueDate
+ _{MsgTableAvsCardIssueDate}
+ $if hasValidToDate
+ _{MsgTableAvsCardValidTo}
+ $if hasCompany
+ _{MsgTableCompany}
+
+
+ $forall c <- crds
+ $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
+
+
+ #{tshowAvsFullCardNo (getFullCardNo c)}
+
+ #{boolSymbol avsDataValid}
+
+ _{avsDataCardColor}
+
+ $forall a <- avsDataCardAreas
+ #{a} #
+ $if hasIssueDate
+
+ $maybe d <- avsDataIssueDate
+ ^{formatTimeW SelFormatDate d}
+ $if hasValidToDate
+
+ $maybe d <- avsDataValidTo
+ ^{formatTimeW SelFormatDate d}
+ $if hasCompany
+
+ $maybe f <- avsDataFirm
+ #{f}
+
+ $maybe f <- avsDataFirm
+ $if (primName == stripCI f)
+ current primary company
+ $else
+ $maybe cid <- compDict f
+ switch company to #{tshow cid}
+ |]
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index 4cebd0026..912e614ac 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -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
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index ebfea411b..da14c9f0c 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -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
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 22266d648..686dc8692 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -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]
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index c1048e1e7..0b0145ef0 100644
--- a/src/Model/Types/Avs.hs
+++ b/src/Model/Types/Avs.hs
@@ -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
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index aa415efff..a9c81a7c4 100644
--- a/src/Utils/Avs.hs
+++ b/src/Utils/Avs.hs
@@ -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