- Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten: -
- ^{contactWgt} -
- ^{cardsWgt} - |] - --
- -- Vorläufige Admin Ansicht AVS Daten. - -- Ansicht zeigt aktuelle Daten. - -- Es erfolgte damit aber noch kein Update der FRADrive Daten. - --
- --
- -- Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. - -- In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar. - --
- -- ^{foldMap jsonWidget mbContact} - --
- -- ^{foldMap jsonWidget mbDataPerson}
- -- |]
+data UserAvsAction = UserAvsSwitchCompany
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+ deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''UserAvsAction id
+instance Button UniWorX UserAvsAction where
+ btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault]
-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|
-
+ ^{contactWgt}
+
+ ^{cardsWgt}
+
+ _{MsgAvsCurrentData}
+ |]
+ 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|
+
+ ^{swForm}
+ |]
diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs
index 50b670d2e..dc235ac3f 100644
--- a/src/Handler/Admin/Test.hs
+++ b/src/Handler/Admin/Test.hs
@@ -112,7 +112,7 @@ postAdminTestR = do
let emailWidget' = wrapForm emailWidget def
{ formAction = Just . SomeRoute $ AdminTestR
, formEncoding = emailEnctype
- , formAttrs = [("uw-async-form", "")]
+ , formAttrs = [asyncSubmitAttr] -- equivalent to [("uw-async-form", "")]
}
now <- liftIO getCurrentTime
diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs
index b24dfd744..81af8b6e4 100644
--- a/src/Handler/Course/User.hs
+++ b/src/Handler/Course/User.hs
@@ -9,12 +9,11 @@ module Handler.Course.User
import Import
import Utils.Form
+import Utils.Mail (pickValidUserEmail)
import Handler.Utils
import Handler.Utils.SheetType
-import Handler.Utils.Profile (pickValidUserEmail)
import Handler.Utils.StudyFeatures
import Handler.Submission.List
-
import Handler.Course.Register
import Jobs.Queue
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.hs b/src/Handler/Utils.hs
index 4648cf647..8043737de 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -161,4 +161,33 @@ reloadKeepGetParams r = liftHandler $ do
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
redirectKeepGetParams route = liftHandler $ do
getps <- reqGetParams <$> getRequest
- redirect (route, getps)
\ No newline at end of file
+ redirect (route, getps)
+
+
+adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
+-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
+adminProblemCell AdminProblemNewCompany{}
+ = i18nCell MsgAdminProblemNewCompany
+adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
+ = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
+adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
+ = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
+adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
+ = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
+adminProblemCell AdminProblemUnknown{adminProblemText}
+ = textCell $ "Problem: " <> adminProblemText
+
+company2msg :: CompanyId -> SomeMessage UniWorX
+company2msg = text2message . ciOriginal . unCompanyKey
+
+msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
+msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
+ SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
+msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $
+ SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
+msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
+ SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
+msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
+ SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
+msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
+ someMessages ["Problem: ", err]
\ No newline at end of file
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index 5759f551c..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
@@ -51,15 +52,12 @@ import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionExce
import Jobs.Queue
import Utils.Avs
-import Utils.Mail (pickValidEmail)
import Utils.Users
import Handler.Utils.Users
-import Handler.Utils.Profile (validPostAddressText)
import Handler.Utils.Company
import Handler.Utils.Qualification
import Handler.Utils.Memcached
-import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
@@ -139,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 lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored!
--- 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
@@ -276,76 +281,9 @@ queryAvsPrimaryCard api = runMaybeT $ do
queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo)
queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard
-_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
-_avsFirmPostAddress = to mkPost
- where
- mkPost afi@AvsFirmInfo{avsFirmFirm} =
- let someAddr = afi ^. _avsFirmPostAddressSimple
- prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n'
- in prefAddr <$> someAddr
-
--- | company post address without company name, better suited for comparisons
-_avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
-_avsFirmPostAddressSimple = to mkPost
- where
- mkPost AvsFirmInfo{..} =
- let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
- commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
- in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
-
-_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
-_avsFirmPrimaryEmail = to mkEmail
- where
- mkEmail afi =
- let candidates = catMaybes
- [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
- , afi ^. _avsFirmEMailSuperior
- , afi ^. _avsFirmEMail
- ]
- in pickValidEmail candidates -- should we return an invalid email rather than none?
-
--- | Not sure this is useful, since postal is ignored if there is no post address anyway
-_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
-_avsFirmPrefersPostal = to mkPostPref
- where
- mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
--- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
-data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting
--- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value,
--- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query
-mkUpdate :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
-mkUpdate ent new (Just old) (CheckAvsUpdate up l)
- | let newval = new ^. l
- , let oldval = old ^. l
- , let entval = ent ^. fieldLensVal up
- , newval /= entval
- , oldval == entval
- = Just (up =. newval)
-mkUpdate _ _ _ _ = Nothing
-
--- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited
-mkUpdate' :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
-mkUpdate' ent new Nothing = mkUpdateDirect ent new
-mkUpdate' ent new just = mkUpdate ent new just
-
-mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
-mkUpdateDirect ent new (CheckAvsUpdate up l)
- | let newval = new ^. l
- , let entval = ent ^. fieldLensVal up
- , newval /= entval
- = Just (up =. newval)
-mkUpdateDirect _ _ _ = Nothing
-
--- | Unconditionally update a record through CheckAvsU
-updateRecord :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> record
-updateRecord ent new (CheckAvsUpdate up l) =
- let newval = new ^. l
- lensRec = fieldLensVal up
- in ent & lensRec .~ newval
-
-- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks
updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
updateAvsUserById apid = do
@@ -396,23 +334,23 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo)
- [ CheckAvsUpdate UserFirstName _avsInfoFirstName
- , CheckAvsUpdate UserSurname _avsInfoLastName
- , CheckAvsUpdate UserDisplayName _avsInfoDisplayName
- , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth
- , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo
- , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just`
- , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo
+ [ CheckUpdate UserFirstName _avsInfoFirstName
+ , CheckUpdate UserSurname _avsInfoLastName
+ , CheckUpdate UserDisplayName _avsInfoDisplayName
+ , CheckUpdate UserBirthday _avsInfoDateOfBirth
+ , CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo
+ , CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just`
+ , CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo
]
em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $
- CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User
+ CheckUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User
em_f_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
- CheckAvsUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI
+ CheckUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI
eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type
frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users,
- CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead
+ CheckUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead
pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card
- CheckAvsUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
+ CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups))
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
[ UserAvsLastSynch =. now
@@ -422,27 +360,27 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
, UserAvsLastCardNo =. newAvsCardNo
]
-- update company association & supervision
- Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
+ Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
- primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand)
+ primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
let oldCompanyId = entityKey <$> oldCompanyEnt
- oldCompanyMb = entityVal <$> oldCompanyEnt
- pst_up = if
- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
- | isNothing oldCompanyMb
- -> mkUpdateDirect usr newCompany $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
- -> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
- | otherwise
- -> Nothing
+ -- oldCompanyMb = entityVal <$> oldCompanyEnt
+ -- pst_up = if
+ -- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
+ -- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
+ -- | isNothing oldCompanyMb
+ -- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
+ -- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
+ -- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
+ -- | otherwise
+ -- -> Nothing
superReasonComDef = tshow SupervisorReasonCompanyDefault
newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
usr_up2 <- case oldAvsFirmInfo of
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely
- -> return Nothing -- => do nothing
+ -> return mempty -- => do nothing
(Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR
|| ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged
-> do -- => just update user company association, keeping supervision privileges
@@ -454,31 +392,39 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of
, UserSupervisorReason ==. Just superReasonComDef] -- user
[ UserSupervisorCompany =. Just newCompanyId]
- return Nothing
+ return mempty
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
-> do
whenIsJust oldCompanyId $ \oldCid -> do
deleteBy $ UniqueUserCompany usrId oldCid
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
- return Nothing
+ return mempty
_ -- company changed completely
-> do
- -- switch user company, keeping old priority
- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
- Nothing ->
- void $ insertUnique newUserComp
- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
- delete ucidOld
- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
- -- adjust supervison
- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
- addCompanySupervisors newCompanyId usrId
- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
+ (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
+ mapM_ reportAdminProblem problems
+ -- Following line does not type, hence additional parameter needed
+ -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
return pst_up
+ -- SPECIALISED CODE, PROBABLY DEPRECATED
+ -- switch user company, keeping old priority
+ -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
+ -- Nothing ->
+ -- void $ insertUnique newUserComp
+ -- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
+ -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
+ -- delete ucidOld
+ -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
+ -- -- adjust supervison
+ -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
+ -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
+ -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
+ -- addCompanySupervisors newCompanyId usrId
+ -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
+ -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
+ -- return pst_up
repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors
- update usrId $ usr_up2 `mcons` usr_up1 -- update user eventually
+ update usrId $ usr_up2 <> usr_up1 -- update user eventually
update uaId avs_ups -- update stored avsinfo for future updates
return (apid, usrId)
@@ -647,15 +593,16 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
where
firmInfo2company =
- [ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI
- , CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI
- , CheckAvsUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade
- -- , CheckAvsUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
- , CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress
- , CheckAvsUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
+ [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI
+ , CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI
+ , CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade
+ -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
+ , CheckUpdate CompanyPostAddress _avsFirmPostAddress
+ , CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
]
+
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler ()
queueAvsUpdateByUID uids pause = do
now <- liftIO getCurrentTime
diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs
index 1c13fd5fd..a5d90c0cb 100644
--- a/src/Handler/Utils/Company.hs
+++ b/src/Handler/Utils/Company.hs
@@ -4,23 +4,28 @@
module Handler.Utils.Company where
+
import Import
--- import Utils.PathPiece
-- import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI
-- import qualified Data.Char as Char
-- import qualified Data.Text as Text
--- import Database.Persist.Postgresql
+import Database.Persist.Postgresql
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.PostgreSQL as E
+import Handler.Utils.Users
+
+
+company2msg :: CompanyId -> SomeMessage UniWorX
+company2msg = text2message . ciOriginal . unCompanyKey
+
-- TODO: use this function in company view Handler.Firm #157
-
-- | add all company supervisors for a given users
addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
=> Key Company -> Key User -> ReaderT backend m ()
@@ -44,3 +49,67 @@ addCompanySupervisors cid uid =
]
)
+
+-- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
+switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
+switchAvsUserCompany usrPostAddrUpd keepOldCompanySupervs uid newCompanyId = do
+ usrRec <- get404 uid
+ newCompany <- get404 newCompanyId
+ mbUsrComp <- getUserPrimaryCompany uid
+ mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
+ mbUsrAvs <- if usrPostAddrUpd then getBy (UniqueUserAvsUser uid) else return Nothing
+ let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec
+ avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just
+ usrPostUp = toMaybe (usrPostAddrUpd && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
+ (UserPostAddress =. Nothing) -- use company address indirectyl instead
+ usrPrefPost = userPrefersPostal usrRec
+ usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
+ (UserPrefersPostal =. companyPrefersPostal newCompany)
+ usrUpdate = catMaybes [usrPostUp, usrPrefPostUp]
+ -- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
+ -- update uid usrUpdate
+ -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
+ case mbUsrComp of
+ Nothing -> do -- create company user
+ void $ insertUnique newUserComp
+ addCompanySupervisors newCompanyId uid
+ return (usrUpdate, mempty)
+ Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute}
+ | newCompanyId == oldCompanyId -> return mempty -- nothing to do
+ | otherwise -> do -- switch company
+ void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
+ [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True]
+ -- supervised by uid
+ supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
+ usrSup <- E.from $ E.table @UserSupervisor
+ E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid
+ E.&&. usrSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
+ E.&&. usrSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
+ let singleSup = E.notExists $ do
+ othSup <- E.from $ E.table @UserSupervisor
+ E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser
+ E.&&. othSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
+ E.&&. othSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
+ return (usrSup, singleSup)
+ newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
+ E.delete $ do
+ usrSup <- E.from $ E.table @UserSupervisor
+ E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
+ return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
+ | (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ]
+ -- supervisors of uid
+ let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef)
+ oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
+ oldAPs <- if keepOldCompanySupervs
+ then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
+ else deleteWhereCount oldSubFltr
+ addCompanySupervisors newCompanyId uid
+ newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
+ let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
+ problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
+ $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
+ newlyUnsupervised
+ return (usrUpdate ,problems)
+ where
+ newUserComp = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
+ superReasonComDef = tshow SupervisorReasonCompanyDefault
\ No newline at end of file
diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs
index 6072a5b2f..782cd02b1 100644
--- a/src/Handler/Utils/Profile.hs
+++ b/src/Handler/Utils/Profile.hs
@@ -6,22 +6,19 @@
-- TODO: consider merging with Handler.Utils.Users?
module Handler.Utils.Profile
( module Utils.Mail
+ , module Utils.Postal
, validDisplayName, checkDisplayName, fixDisplayName
- , validPostAddress, validPostAddressText
, validFraportPersonalNumber
) where
import Import.NoFoundation
-import Data.Char
import qualified Data.Text as Text
-import qualified Data.Text.Lazy as LT
--- import qualified Data.CaseInsensitive as CI
-
import qualified Data.MultiSet as MultiSet
import qualified Data.Set as Set
import Utils.Mail
+import Utils.Postal
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
-- Input "givennames surname" is left unchanged, except for removing excess whitespace
@@ -63,23 +60,6 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s
splitAdd = Text.split isAdd
makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd
-
--- | Primitive postal address requires at least one alphabetic character, one digit and a line break
-validPostAddress :: Maybe StoredMarkup -> Bool
-validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr
-validPostAddress _ = False
-
-validPostAddressText :: Text -> Bool
-validPostAddressText = validPostAddressLazyText . LT.fromStrict
-
-validPostAddressLazyText :: LT.Text -> Bool
-validPostAddressLazyText addr
- | Just _ <- LT.find isLetter addr
- , Just _ <- LT.find isNumber addr
- -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
- = 1 < length (LT.lines addr)
-validPostAddressLazyText _ = False
-
validFraportPersonalNumber :: Maybe Text -> Bool
validFraportPersonalNumber Nothing = False
validFraportPersonalNumber (Just t)
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 9e39ca041..686dc8692 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -15,7 +15,7 @@ module Handler.Utils.Users
, guessUser, guessUserByEmail
, UserAssimilateException(..), UserAssimilateExceptionReason(..)
, assimilateUser
- , getUserPrimaryCompany
+ , getUserPrimaryCompany, getUserPrimaryCompanyAddress
, getUserEmail
, getEmailAddress, getJustEmailAddress
, getEmailAddressFor, getJustEmailAddressFor
@@ -76,11 +76,15 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
assemble = Text.intercalate "."
-getUserPrimaryCompany :: UserId -> (Company -> Maybe a) -> DB (Maybe a)
-getUserPrimaryCompany uid prj = runMaybeT $ do
- Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $
- selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True]
- [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany]
+-- Note: Entity can be recovered, since CompanyShort is also the key
+getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany)
+getUserPrimaryCompany uid = entityVal <<$>>
+ selectFirst [UserCompanyUser ==. uid]
+ [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany]
+
+getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DB (Maybe a)
+getUserPrimaryCompanyAddress uid prj = runMaybeT $ do
+ UserCompany{userCompanyCompany=cid, userCompanyUseCompanyAddress=True} <- MaybeT $ getUserPrimaryCompany uid -- return Nothing if company address is not to be used
company <- MaybeT $ get cid
-- hoistMaybe $ prj company
MaybeT $ pure $ prj company
@@ -126,7 +130,7 @@ getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
= return $ Just userDisplayEmail
| otherwise
= do
- compEmailMb <- getUserPrimaryCompany uid companyEmail
+ compEmailMb <- getUserPrimaryCompanyAddress uid companyEmail
return $ pickValidEmail' $ mcons compEmailMb [userEmail]
-- address is prefixed with userDisplayName
@@ -136,7 +140,7 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
= prefixMarkupName pa
| otherwise
= do
- getUserPrimaryCompany uid companyPostAddress >>= \case
+ getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
(Just pa)
-> prefixMarkupName pa
Nothing
@@ -154,7 +158,7 @@ getPostalAddress' Entity{entityKey=uid, entityVal=User{..}}
= return res
| otherwise
= do
- getUserPrimaryCompany uid companyPostAddress >>= \case
+ getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
res@(Just _)
-> return res
Nothing
diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs
index fb1b0f75b..12abd0c4d 100644
--- a/src/Jobs/Handler/QueueNotification.hs
+++ b/src/Jobs/Handler/QueueNotification.hs
@@ -16,7 +16,7 @@ import Jobs.Queue
import qualified Data.Set as Set
--- import Handler.Utils.Profile (pickValidUserEmail')
+-- import Utils.Mail (pickValidUserEmail')
import Handler.Utils.Users (getUserEmail)
import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam
diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs
index f3dd0e507..0b0145ef0 100644
--- a/src/Model/Types/Avs.hs
+++ b/src/Model/Types/Avs.hs
@@ -12,6 +12,9 @@ module Model.Types.Avs
) where
import Import.NoModel hiding ((.=))
+
+import Model.Types.Markup
+
import Database.Persist.Sql
import qualified Database.Esqueleto.Experimental as E
import qualified Data.Csv as Csv
@@ -27,6 +30,9 @@ import qualified Data.Set as Set
import Data.Aeson
import Data.Aeson.Types as Aeson
+import Utils.Postal (validPostAddressText)
+import Utils.Mail (pickValidEmail)
+
{-
-- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
@@ -441,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
@@ -624,10 +633,41 @@ data AvsFirmInfo = AvsFirmInfo
} deriving (Eq, Ord, Show, Generic, NFData, Binary)
makeLenses_ ''AvsFirmInfo
--- additional convenience lenses declared in Handler.Utils.Avs due to required dependencies:
--- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
--- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
--- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
+-- additional convenience lenses:
+
+_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
+_avsFirmPostAddress = to mkPost
+ where
+ mkPost afi@AvsFirmInfo{avsFirmFirm} =
+ let someAddr = afi ^. _avsFirmPostAddressSimple
+ prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n'
+ in prefAddr <$> someAddr
+
+-- | company post address without company name, better suited for comparisons
+_avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
+_avsFirmPostAddressSimple = to mkPost
+ where
+ mkPost AvsFirmInfo{..} =
+ let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
+ commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
+ in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
+
+_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
+_avsFirmPrimaryEmail = to mkEmail
+ where
+ mkEmail afi =
+ let candidates = catMaybes
+ [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
+ , afi ^. _avsFirmEMailSuperior
+ , afi ^. _avsFirmEMail
+ ]
+ in pickValidEmail candidates -- should we return an invalid email rather than none?
+
+-- | Not sure this is useful, since postal is ignored if there is no post address anyway
+_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
+_avsFirmPrefersPostal = to mkPostPref
+ where
+ mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
-- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead
-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text
@@ -640,16 +680,16 @@ makeLenses_ ''AvsFirmInfo
instance FromJSON AvsFirmInfo where
parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo
- <$> (o .: "Firm" <&> Text.strip) -- AVS may contain leading/trailing whitespace
- <*> o .: "FirmNo"
- <*> (o .: "Abbreviation" <&> Text.strip) -- AVS may contain leading/trailing whitespace
- <*> o .:?! "ZIPCode"
- <*> o .:?! "City"
- <*> o .:?! "Country"
- <*> o .:?! "StreetANDHouseNo"
- <*> o .:?! "EMail"
- <*> o .:?! "EMailSuperior"
- <*> o .:?! "Communication"
+ <$> (o .: "Firm" <&> Text.strip) -- AVS often contains leading/trailing whitespace
+ <*> o .: "FirmNo"
+ <*> (o .: "Abbreviation" <&> Text.strip)
+ <*> (o .:?! "ZIPCode" <&> fmap Text.strip)
+ <*> (o .:?! "City" <&> fmap Text.strip)
+ <*> (o .:?! "Country" <&> fmap Text.strip)
+ <*> (o .:?! "StreetANDHouseNo" <&> fmap Text.strip)
+ <*> (o .:?! "EMail" <&> fmap Text.strip)
+ <*> (o .:?! "EMailSuperior" <&> fmap Text.strip)
+ <*> o .:?! "Communication"
instance ToJSON AvsFirmInfo where
toJSON AvsFirmInfo{..} = object $ catMaybes
diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs
index b2a22915d..a250927c4 100644
--- a/src/Model/Types/Markup.hs
+++ b/src/Model/Types/Markup.hs
@@ -11,6 +11,7 @@ module Model.Types.Markup
, I18nStoredMarkup
, markupIsSmallish
, html2textlines
+ , isSimilarMarkup
) where
import Import.NoModel
@@ -51,6 +52,11 @@ data StoredMarkup = StoredMarkup
deriving (Read, Show, Generic)
deriving anyclass (Binary, Hashable, NFData)
+isSimilarMarkup :: StoredMarkup -> StoredMarkup -> Bool
+isSimilarMarkup StoredMarkup{markupInputFormat=af, markupInput=ai}
+ StoredMarkup{markupInputFormat=bf, markupInput=bi}
+ = af==bf && ai == bi
+
instance Canonical (Maybe StoredMarkup) where
canonical Nothing = Nothing
canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if
diff --git a/src/Utils.hs b/src/Utils.hs
index 3ac9fb955..21685f564 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -922,7 +922,6 @@ deepAlt altFst _ = altFst
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty = flip foldMap
-
-- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a`
filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
filterMaybe c r@(Just x) | c x = r
@@ -950,6 +949,7 @@ positiveSum = maybePositive . getSum
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM dft act mb = mb >>= maybe dft act
+-- maybeEmptyM, maybeNotingM
traverseJoin :: (Applicative m, Traversable maybe, Monad maybe) => (a -> m (maybe b)) -> maybe a -> m (maybe b)
traverseJoin f x = join <$> (f `traverse` x)
@@ -1215,6 +1215,10 @@ shortCircuitM sc binOp mx my = do
guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f
+guardMonoidM :: (Applicative f, Monoid m) => Bool -> f m -> f m
+guardMonoidM False _ = pure mempty
+guardMonoidM True x = x
+
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = x >>= assertM' f
diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs
index a9bbdfb66..c54b80864 100644
--- a/src/Utils/Avs.hs
+++ b/src/Utils/Avs.hs
@@ -76,25 +76,44 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
#ifdef DEVELOPMENT
mkAvsQuery _ _ _ = AvsQuery
- { avsQueryPerson =
- let
- sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty
- stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty
- steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty
-
- in \case
- AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson steffen
- AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> return . Right $ AvsResponsePerson steffen
- AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson stephan
- AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> return . Right $ AvsResponsePerson sarah
- AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> return . Right $ AvsResponsePerson $ steffen <> sarah
- AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson $ steffen <> stephan
- _ -> return . Right $ AvsResponsePerson mempty
- , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty
- , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
+ { avsQueryPerson = return . Right . fakePerson
+ , avsQueryStatus = return . Right . fakeStatus
+ , avsQueryContact = return . Right . fakeContact
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
, avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty
}
+ where
+ fakePerson :: AvsQueryPerson -> AvsResponsePerson
+ fakePerson =
+ let
+ sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty
+ stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty
+ steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty
+ sumpfi1 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty
+ sumpfi2 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604387) mempty
+ sumpfi3 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604591) mempty
+ in \case
+ AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson steffen
+ AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> AvsResponsePerson steffen
+ AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson stephan
+ AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> AvsResponsePerson sarah
+ AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> AvsResponsePerson $ steffen <> sarah
+ AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ steffen <> stephan
+ AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00006666"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
+ AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00007777"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
+ AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00008888"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
+ _ -> AvsResponsePerson mempty
+
+ fakeStatus :: AvsQueryStatus -> AvsResponseStatus
+ fakeStatus (AvsQueryStatus (Set.toList -> (api:_))) = AvsResponseStatus $ Set.singleton $ AvsStatusPerson api $ Set.fromList
+ [ AvsDataPersonCard True (Just $ fromGregorian 2026 5 1) Nothing AvsCardColorGelb (Set.fromList ['F','R','C']) Nothing Nothing Nothing (Just "Fraport AG") (AvsCardNo "6666") "4"
+ , AvsDataPersonCard False (Just $ fromGregorian 2025 6 2) Nothing AvsCardColorRot (Set.fromList ['F','A' ]) Nothing Nothing Nothing (Just "N*ICE Aircraft Services & Support GmbH") (AvsCardNo "7777") "4"
+ , AvsDataPersonCard True (Just $ fromGregorian 2028 7 3) Nothing AvsCardColorBlau mempty Nothing Nothing Nothing (Just "Fraport Facility Services GmbH") (AvsCardNo "8888") "4"
+ ]
+ fakeStatus _ = AvsResponseStatus mempty
+ fakeContact :: AvsQueryContact -> AvsResponseContact
+ fakeContact (AvsQueryContact (Set.toList -> ((AvsObjPersonId api):_))) = AvsResponseContact $ Set.singleton $ AvsDataContact api (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
+ fakeContact _ = AvsResponseContact mempty
#else
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> if q == def then return $ Right $ AvsResponsePerson mempty else -- prevent empty queries
@@ -132,7 +151,7 @@ splitQuery rawQuery q
#endif
-----------------------
--- Utility Functions --
+-- Utility Functions -- DEPRECTATED
-----------------------
-- retrieve AvsDataPersonCard with longest validity for a given licence,
@@ -147,58 +166,58 @@ splitQuery rawQuery q
-- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
-- | DEPRECTATED
-getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
-getCompanyAddress card@AvsDataPersonCard{..}
- | Just street <- avsDataStreet
- , Just pcode <- avsDataPostalCode
- , Just city <- avsDataCity
- = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card)
- | isJust avsDataFirm = (avsDataFirm, Nothing, Just card)
- | otherwise = (Nothing, Nothing, Nothing)
+-- getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
+-- getCompanyAddress card@AvsDataPersonCard{..}
+-- | Just street <- avsDataStreet
+-- , Just pcode <- avsDataPostalCode
+-- , Just city <- avsDataCity
+-- = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card)
+-- | isJust avsDataFirm = (avsDataFirm, Nothing, Just card)
+-- | otherwise = (Nothing, Nothing, Nothing)
--- | From a set of card, choose the one with the most complete postal address.
--- Returns company, postal address and the associated card where the address was taken from
-guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
-guessLicenceAddress cards
- | Just c <- Set.lookupMax cards
- , card <- Set.foldr pickLicenceAddress c cards
- = getCompanyAddress card
- | otherwise = (Nothing, Nothing, Nothing)
+-- -- | From a set of card, choose the one with the most complete postal address.
+-- -- Returns company, postal address and the associated card where the address was taken from
+-- guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
+-- guessLicenceAddress cards
+-- | Just c <- Set.lookupMax cards
+-- , card <- Set.foldr pickLicenceAddress c cards
+-- = getCompanyAddress card
+-- | otherwise = (Nothing, Nothing, Nothing)
-hasAddress :: AvsDataPersonCard -> Bool
-hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
+-- hasAddress :: AvsDataPersonCard -> Bool
+-- hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
-pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
-pickLicenceAddress a b
- | Just r <- pickBetter' hasAddress = r -- prefer card with complete address
- | Just r <- pickBetter' avsDataValid = r -- prefer valid cards
- | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
- | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
- | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc.
- | avsDataCardColor a < avsDataCardColor b = b
- | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
- | avsDataIssueDate a < avsDataIssueDate b = b
- | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
- | avsDataValidTo a < avsDataValidTo b = b
- | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
- | a <= b = b -- respect natural Ord instance
- | otherwise = a
- where
- pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
- pickBetter' = pickBetter a b
- licenceRollfeld = licence2char AvsLicenceRollfeld
- licenceVorfeld = licence2char AvsLicenceVorfeld
+-- pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
+-- pickLicenceAddress a b
+-- | Just r <- pickBetter' hasAddress = r -- prefer card with complete address
+-- | Just r <- pickBetter' avsDataValid = r -- prefer valid cards
+-- | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
+-- | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
+-- | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc.
+-- | avsDataCardColor a < avsDataCardColor b = b
+-- | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
+-- | avsDataIssueDate a < avsDataIssueDate b = b
+-- | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
+-- | avsDataValidTo a < avsDataValidTo b = b
+-- | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
+-- | a <= b = b -- respect natural Ord instance
+-- | otherwise = a
+-- where
+-- pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
+-- pickBetter' = pickBetter a b
+-- licenceRollfeld = licence2char AvsLicenceRollfeld
+-- licenceVorfeld = licence2char AvsLicenceVorfeld
-{- Note:
-For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
-bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
- compare a b = compareBy avsDataValid
- <> compareBy avsDataValidTo
- <> compareBy avsDataIssueDate
- ...
- where
- compareBy f = compare `on` f a b
--}
+-- {- Note:
+-- For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
+-- bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
+-- compare a b = compareBy avsDataValid
+-- <> compareBy avsDataValidTo
+-- <> compareBy avsDataIssueDate
+-- ...
+-- where
+-- compareBy f = compare `on` f a b
+-- -}
-- Merges several answers by AvsPersonId, preserving all AvsPersonCards
mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs
index fdad68adf..1bbadb1f6 100644
--- a/src/Utils/DB.hs
+++ b/src/Utils/DB.hs
@@ -326,3 +326,41 @@ instance WithRunDB backend m (ReaderT backend m) where
-- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
-- runCachedDBRunnerUsing act getRunnerNoLock
+
+
+
+-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
+data CheckUpdate record iraw = forall typ. (Eq typ, PersistField typ) => CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting
+
+
+-- | Compute necessary updates. Given a database record, the new and old raw data, and a pair consisting of a getter from raw data to a value and an EntityField of the same value,
+-- an update is returned, if the current value is identical to the old value, which changed in the new raw data
+mkUpdate :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record)
+mkUpdate ent new (Just old) (CheckUpdate up l)
+ | let newval = new ^. l
+ , let oldval = old ^. l
+ , let entval = ent ^. fieldLensVal up
+ , newval /= entval
+ , oldval == entval
+ = Just (up =. newval)
+mkUpdate _ _ _ _ = Nothing
+
+-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited
+mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record)
+mkUpdate' ent new Nothing = mkUpdateDirect ent new
+mkUpdate' ent new just = mkUpdate ent new just
+
+mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record)
+mkUpdateDirect ent new (CheckUpdate up l)
+ | let newval = new ^. l
+ , let entval = ent ^. fieldLensVal up
+ , newval /= entval
+ = Just (up =. newval)
+mkUpdateDirect _ _ _ = Nothing
+
+-- | Unconditionally update a record through ChecUpdate
+updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record
+updateRecord ent new (CheckUpdate up l) =
+ let newval = new ^. l
+ lensRec = fieldLensVal up
+ in ent & lensRec .~ newval
\ No newline at end of file
diff --git a/src/Utils/Postal.hs b/src/Utils/Postal.hs
new file mode 100644
index 000000000..65c7b2d0a
--- /dev/null
+++ b/src/Utils/Postal.hs
@@ -0,0 +1,32 @@
+-- SPDX-FileCopyrightText: 2024 Steffen Jost
- $if avsNoOk
-
-
-
_{MsgAvsCardNo}
- _{MsgTableAvsCardValid}
- _{MsgAvsCardColor}
- _{MsgAvsCardAreas}
- _{MsgTableCompany}
- _{MsgTableAvsCardIssueDate}
- _{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}
-
- $maybe d <- avsDataIssueDate
- ^{formatTimeW SelFormatDate d}
-
- $maybe d <- avsDataValidTo
- ^{formatTimeW SelFormatDate d}
- |]
+ 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) ->
+ if null adcs
+ then [whamlet|_{MsgAvsPersonSearchEmpty}|]
+ else
+ let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
+ in mconcat cs
+ cardsWgt = case mbStatus of
+ Left err -> exceptionWgt err
+ Right (AvsResponseStatus asts) ->
+ if null asts
+ then [whamlet|This should not occur|] -- TODO
+ else
+ let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
+ in mconcat cs
+ [whamlet|
+
+ $if avsNoOk
+
+
+
+
+ $forall c <- Set.toDescList crds
+ $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
+ _{MsgAvsCardNo}
+ _{MsgTableAvsCardValid}
+ _{MsgAvsCardColor}
+ _{MsgAvsCardAreas}
+ $if hasIssueDate
+ _{MsgTableAvsCardIssueDate}
+ $if hasValidToDate
+ _{MsgTableAvsCardValidTo}
+ $if hasCompany
+ _{MsgTableCompany}
+ _{MsgAvsPrimaryCompany}
+
+
+ #{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
+ $with fci <- stripCI f
+ $maybe primName <- mbPrimName
+ $if (primName == fci)
+ _{MsgAvsPrimaryCompany}
+