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

chore(avs): add function to change to secondary company

Browse Source
This commit is contained in:
Steffen Jost 2024-04-30 17:45:29 +02:00
parent 697979c277
commit fdbaa3c9d4
17 changed files with 375 additions and 288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/categories/admin/de-de-formal.msg
View File

@ -128,7 +128,8 @@ AdminProblemInfo: Problembeschreibung
AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markiert AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markiert
AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet
AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma AdminProblemSupervisorNewCompany b@Bool: Dieser Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma
AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma
AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma
AdminProblemUser: Betroffener AdminProblemUser: Betroffener
ProblemTableMarkSolved: Als erledigt markieren ProblemTableMarkSolved: Als erledigt markieren

3
messages/uniworx/categories/admin/en-eu.msg
View File

@ -128,7 +128,8 @@ AdminProblemInfo: Problem
AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved
AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened
AdminProblemNewCompany: New company from AVS; verify and add default supervisors AdminProblemNewCompany: New company from AVS; verify and add default supervisors
AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company AdminProblemSupervisorNewCompany b: This default company supervisor #{boolText mempty "with reroute" b} changed to new company
AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company
AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company
AdminProblemUser: Affected AdminProblemUser: Affected
ProblemTableMarkSolved: Mark done ProblemTableMarkSolved: Mark done

9
src/Audit/Types.hs
View File

@ -260,7 +260,7 @@ derivePersistFieldJSON ''Transaction
-- Datatype for raising admin awareness to certain problems -- Datatype for raising admin awareness to certain problems
-- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries -- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries
-- Note that is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell -- Note that there is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell dealing with special cases instead
data AdminProblem data AdminProblem
= AdminProblemNewCompany -- new company was noticed, presumably without supervisors = AdminProblemNewCompany -- new company was noticed, presumably without supervisors
{ adminProblemCompany :: CompanyId { adminProblemCompany :: CompanyId
@ -271,8 +271,13 @@ data AdminProblem
, adminProblemCompanyNew :: CompanyId -- new company of the user , adminProblemCompanyNew :: CompanyId -- new company of the user
, adminProblemSupervisorReroute :: Bool -- reroute included? , adminProblemSupervisorReroute :: Bool -- reroute included?
} }
| AdminProblemSupervisorLeftCompany
{ adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to supervisor change
, adminProblemCompany :: CompanyId -- old company
, adminProblemSupervisorReroute :: Bool -- reroute included?
}
| AdminProblemNewlyUnsupervised | AdminProblemNewlyUnsupervised
{ adminProblemUser :: UserId -- user who had supervsior but no longer has { adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to user company change
, adminProblemCompanyOld :: Maybe CompanyId -- old company , adminProblemCompanyOld :: Maybe CompanyId -- old company
, adminProblemCompanyNew :: CompanyId -- new company of the user , adminProblemCompanyNew :: CompanyId -- new company of the user
} }

2
src/Handler/Admin.hs
View File

@ -380,6 +380,8 @@ adminProblemCell AdminProblemNewCompany{}
= i18nCell MsgAdminProblemNewCompany = i18nCell MsgAdminProblemNewCompany
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
= i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
= i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
= i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemUnknown{adminProblemText} adminProblemCell AdminProblemUnknown{adminProblemText}

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

@ -710,37 +710,6 @@ getAdminAvsUserR uuid = do
<p> <p>
^{cardsWgt} ^{cardsWgt}
|] |]
-- <p>
-- Vorläufige Admin Ansicht AVS Daten.
-- Ansicht zeigt aktuelle Daten.
-- Es erfolgte damit aber noch kein Update der FRADrive Daten.
-- <p>
-- <dl .deflist>
-- <dt .deflist__dt>InfoPersonContact <br>
-- <i>(bevorzugt)
-- <dd .deflist__dd>
-- $case mbContact
-- $of Left err
-- ^{exceptionWgt err}
-- $of Right contactInfo
-- #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
-- <dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
-- <i>(benötigt mehrere AVS Abfragen)
-- <dd .deflist__dd>
-- $maybe dataPerson <- mbDataPerson
-- #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
-- $nothing
-- Keine Daten erhalten.
-- <h3>
-- Provisorische formatierte Ansicht
-- <p>
-- 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.
-- <p>
-- ^{foldMap jsonWidget mbContact}
-- <p>
-- ^{foldMap jsonWidget mbDataPerson}
-- |]
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
@ -787,7 +756,9 @@ mkContactWgt warnBolt reqAvsNo AvsDataContact
|] |]
mkCardsWgt :: Set AvsDataPersonCard -> Widget mkCardsWgt :: Set AvsDataPersonCard -> Widget
mkCardsWgt crds = mkCardsWgt crds = do
let hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds
hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds
[whamlet| [whamlet|
<table> <table>
<thead> <thead>
@ -796,8 +767,10 @@ mkCardsWgt crds =
<th>_{MsgAvsCardColor} <th>_{MsgAvsCardColor}
<th>_{MsgAvsCardAreas} <th>_{MsgAvsCardAreas}
<th>_{MsgTableCompany} <th>_{MsgTableCompany}
<th>_{MsgTableAvsCardIssueDate} $if hasIssueDate
<th>_{MsgTableAvsCardValidTo} <th>_{MsgTableAvsCardIssueDate}
$if hasValidToDate
<th>_{MsgTableAvsCardValidTo}
<tbody> <tbody>
$forall c <- crds $forall c <- crds
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
@ -814,12 +787,14 @@ mkCardsWgt crds =
<td> <td>
$maybe f <- avsDataFirm $maybe f <- avsDataFirm
#{f} #{f}
<td> $if hasIssueDate
$maybe d <- avsDataIssueDate <td>
^{formatTimeW SelFormatDate d} $maybe d <- avsDataIssueDate
<td> ^{formatTimeW SelFormatDate d}
$maybe d <- avsDataValidTo $if hasValidToDate
^{formatTimeW SelFormatDate d} <td>
$maybe d <- avsDataValidTo
^{formatTimeW SelFormatDate d}
|] |]

3
src/Handler/Course/User.hs
View File

@ -9,12 +9,11 @@ module Handler.Course.User
import Import import Import
import Utils.Form import Utils.Form
import Utils.Mail (pickValidUserEmail)
import Handler.Utils import Handler.Utils
import Handler.Utils.SheetType import Handler.Utils.SheetType
import Handler.Utils.Profile (pickValidUserEmail)
import Handler.Utils.StudyFeatures import Handler.Utils.StudyFeatures
import Handler.Submission.List import Handler.Submission.List
import Handler.Course.Register import Handler.Course.Register
import Jobs.Queue import Jobs.Queue

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

@ -51,15 +51,12 @@ import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionExce
import Jobs.Queue import Jobs.Queue
import Utils.Avs import Utils.Avs
import Utils.Mail (pickValidEmail)
import Utils.Users import Utils.Users
import Handler.Utils.Users import Handler.Utils.Users
import Handler.Utils.Profile (validPostAddressText)
import Handler.Utils.Company import Handler.Utils.Company
import Handler.Utils.Qualification import Handler.Utils.Qualification
import Handler.Utils.Memcached import Handler.Utils.Memcached
import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -140,7 +137,7 @@ catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHan
------------------ ------------------
-- TODO: delete lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored! -- TODO: delete deprecated Utility Functions from Utils.Avs as well
-- lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => -- lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
-- AvsPersonId -> m (Maybe AvsDataPerson) -- AvsPersonId -> m (Maybe AvsDataPerson)
-- lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) -- lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
@ -276,76 +273,9 @@ queryAvsPrimaryCard api = runMaybeT $ do
queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo) queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo)
queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard 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 -- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks
updateAvsUserById :: AvsPersonId -> DB (Maybe UserId) updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
updateAvsUserById apid = do updateAvsUserById apid = do
@ -396,23 +326,23 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo)
[ CheckAvsUpdate UserFirstName _avsInfoFirstName [ CheckUpdate UserFirstName _avsInfoFirstName
, CheckAvsUpdate UserSurname _avsInfoLastName , CheckUpdate UserSurname _avsInfoLastName
, CheckAvsUpdate UserDisplayName _avsInfoDisplayName , CheckUpdate UserDisplayName _avsInfoDisplayName
, CheckAvsUpdate UserBirthday _avsInfoDateOfBirth , CheckUpdate UserBirthday _avsInfoDateOfBirth
, CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo , CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo
, CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` , CheckUpdate 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 UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo
] ]
em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $ 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. 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 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, 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 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)) usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups))
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
[ UserAvsLastSynch =. now [ UserAvsLastSynch =. now
@ -422,27 +352,27 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
, UserAvsLastCardNo =. newAvsCardNo , UserAvsLastCardNo =. newAvsCardNo
] ]
-- update company association & supervision -- update company association & supervision
Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand) primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
let oldCompanyId = entityKey <$> oldCompanyEnt let oldCompanyId = entityKey <$> oldCompanyEnt
oldCompanyMb = entityVal <$> oldCompanyEnt -- oldCompanyMb = entityVal <$> oldCompanyEnt
pst_up = if -- pst_up = if
-- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines -- -- | 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) -- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
| isNothing oldCompanyMb -- | isNothing oldCompanyMb
-> mkUpdateDirect usr newCompany $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) -- -> 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 -- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
-> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference -- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
| otherwise -- | otherwise
-> Nothing -- -> Nothing
superReasonComDef = tshow SupervisorReasonCompanyDefault superReasonComDef = tshow SupervisorReasonCompanyDefault
newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done 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 usr_up2 <- case oldAvsFirmInfo of
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely _ | 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 (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR
|| ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged || ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged
-> do -- => just update user company association, keeping supervision privileges -> do -- => just update user company association, keeping supervision privileges
@ -454,31 +384,39 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of , UserSupervisorCompany ==. Just ocid -- to new company, regardless of
, UserSupervisorReason ==. Just superReasonComDef] -- user , UserSupervisorReason ==. Just superReasonComDef] -- user
[ UserSupervisorCompany =. Just newCompanyId] [ UserSupervisorCompany =. Just newCompanyId]
return Nothing return mempty
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
-> do -> do
whenIsJust oldCompanyId $ \oldCid -> do whenIsJust oldCompanyId $ \oldCid -> do
deleteBy $ UniqueUserCompany usrId oldCid deleteBy $ UniqueUserCompany usrId oldCid
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
return Nothing return mempty
_ -- company changed completely _ -- company changed completely
-> do -> do
-- switch user company, keeping old priority (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
(getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case mapM_ reportAdminProblem problems
Nothing -> -- Following line does not type, hence additional parameter needed
void $ insertUnique newUserComp -- 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)
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
return pst_up 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 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 update uaId avs_ups -- update stored avsinfo for future updates
return (apid, usrId) return (apid, usrId)
@ -647,15 +585,16 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
where where
firmInfo2company = firmInfo2company =
[ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI
, CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI , CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI
, CheckAvsUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade , CheckUpdate 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 -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
, CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress , CheckUpdate CompanyPostAddress _avsFirmPostAddress
, CheckAvsUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just , CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
] ]
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler () queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler ()
queueAvsUpdateByUID uids pause = do queueAvsUpdateByUID uids pause = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime

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

@ -4,20 +4,21 @@
module Handler.Utils.Company where module Handler.Utils.Company where
import Import import Import
-- import Utils.PathPiece
-- import Data.CaseInsensitive (CI) -- import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI -- import qualified Data.CaseInsensitive as CI
-- import qualified Data.Char as Char -- import qualified Data.Char as Char
-- import qualified Data.Text as Text -- import qualified Data.Text as Text
-- import Database.Persist.Postgresql import Database.Persist.Postgresql
-- import Database.Esqueleto.Experimental ((:&)(..)) -- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.PostgreSQL as E
import Handler.Utils.Users
-- TODO: use this function in company view Handler.Firm #157 -- TODO: use this function in company view Handler.Firm #157
@ -44,3 +45,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

24
src/Handler/Utils/Profile.hs
View File

@ -6,22 +6,19 @@
-- TODO: consider merging with Handler.Utils.Users? -- TODO: consider merging with Handler.Utils.Users?
module Handler.Utils.Profile module Handler.Utils.Profile
( module Utils.Mail ( module Utils.Mail
, module Utils.Postal
, validDisplayName, checkDisplayName, fixDisplayName , validDisplayName, checkDisplayName, fixDisplayName
, validPostAddress, validPostAddressText
, validFraportPersonalNumber , validFraportPersonalNumber
) where ) where
import Import.NoFoundation import Import.NoFoundation
import Data.Char
import qualified Data.Text as Text 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.MultiSet as MultiSet
import qualified Data.Set as Set import qualified Data.Set as Set
import Utils.Mail import Utils.Mail
import Utils.Postal
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname". -- | 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 -- 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 splitAdd = Text.split isAdd
makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd 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 :: Maybe Text -> Bool
validFraportPersonalNumber Nothing = False validFraportPersonalNumber Nothing = False
validFraportPersonalNumber (Just t) validFraportPersonalNumber (Just t)

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

@ -15,7 +15,7 @@ module Handler.Utils.Users
, guessUser, guessUserByEmail , guessUser, guessUserByEmail
, UserAssimilateException(..), UserAssimilateExceptionReason(..) , UserAssimilateException(..), UserAssimilateExceptionReason(..)
, assimilateUser , assimilateUser
, getUserPrimaryCompany , getUserPrimaryCompany, getUserPrimaryCompanyAddress
, getUserEmail , getUserEmail
, getEmailAddress, getJustEmailAddress , getEmailAddress, getJustEmailAddress
, getEmailAddressFor, getJustEmailAddressFor , getEmailAddressFor, getJustEmailAddressFor
@ -76,11 +76,14 @@ abbrvName User{userDisplayName, userFirstName, userSurname} =
assemble = Text.intercalate "." assemble = Text.intercalate "."
getUserPrimaryCompany :: UserId -> (Company -> Maybe a) -> DB (Maybe a) getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany)
getUserPrimaryCompany uid prj = runMaybeT $ do getUserPrimaryCompany uid = entityVal <<$>>
Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ selectFirst [UserCompanyUser ==. uid]
selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany]
[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 company <- MaybeT $ get cid
-- hoistMaybe $ prj company -- hoistMaybe $ prj company
MaybeT $ pure $ prj company MaybeT $ pure $ prj company
@ -126,7 +129,7 @@ getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}}
= return $ Just userDisplayEmail = return $ Just userDisplayEmail
| otherwise | otherwise
= do = do
compEmailMb <- getUserPrimaryCompany uid companyEmail compEmailMb <- getUserPrimaryCompanyAddress uid companyEmail
return $ pickValidEmail' $ mcons compEmailMb [userEmail] return $ pickValidEmail' $ mcons compEmailMb [userEmail]
-- address is prefixed with userDisplayName -- address is prefixed with userDisplayName
@ -136,7 +139,7 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}}
= prefixMarkupName pa = prefixMarkupName pa
| otherwise | otherwise
= do = do
getUserPrimaryCompany uid companyPostAddress >>= \case getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
(Just pa) (Just pa)
-> prefixMarkupName pa -> prefixMarkupName pa
Nothing Nothing
@ -154,7 +157,7 @@ getPostalAddress' Entity{entityKey=uid, entityVal=User{..}}
= return res = return res
| otherwise | otherwise
= do = do
getUserPrimaryCompany uid companyPostAddress >>= \case getUserPrimaryCompanyAddress uid companyPostAddress >>= \case
res@(Just _) res@(Just _)
-> return res -> return res
Nothing Nothing

2
src/Jobs/Handler/QueueNotification.hs
View File

@ -16,7 +16,7 @@ import Jobs.Queue
import qualified Data.Set as Set import qualified Data.Set as Set
-- import Handler.Utils.Profile (pickValidUserEmail') -- import Utils.Mail (pickValidUserEmail')
import Handler.Utils.Users (getUserEmail) import Handler.Utils.Users (getUserEmail)
import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam import Handler.Utils.ExamOffice.ExternalExam

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

@ -12,6 +12,9 @@ module Model.Types.Avs
) where ) where
import Import.NoModel hiding ((.=)) import Import.NoModel hiding ((.=))
import Model.Types.Markup
import Database.Persist.Sql import Database.Persist.Sql
import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Experimental as E
import qualified Data.Csv as Csv import qualified Data.Csv as Csv
@ -27,6 +30,9 @@ import qualified Data.Set as Set
import Data.Aeson import Data.Aeson
import Data.Aeson.Types as 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. -- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
@ -624,10 +630,41 @@ data AvsFirmInfo = AvsFirmInfo
} deriving (Eq, Ord, Show, Generic, NFData, Binary) } deriving (Eq, Ord, Show, Generic, NFData, Binary)
makeLenses_ ''AvsFirmInfo makeLenses_ ''AvsFirmInfo
-- additional convenience lenses declared in Handler.Utils.Avs due to required dependencies: -- additional convenience lenses:
-- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
-- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
-- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) _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 -- 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 -- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text
@ -640,16 +677,16 @@ makeLenses_ ''AvsFirmInfo
instance FromJSON AvsFirmInfo where instance FromJSON AvsFirmInfo where
parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo
<$> (o .: "Firm" <&> Text.strip) -- AVS may contain leading/trailing whitespace <$> (o .: "Firm" <&> Text.strip) -- AVS often contains leading/trailing whitespace
<*> o .: "FirmNo" <*> o .: "FirmNo"
<*> (o .: "Abbreviation" <&> Text.strip) -- AVS may contain leading/trailing whitespace <*> (o .: "Abbreviation" <&> Text.strip)
<*> o .:?! "ZIPCode" <*> (o .:?! "ZIPCode" <&> fmap Text.strip)
<*> o .:?! "City" <*> (o .:?! "City" <&> fmap Text.strip)
<*> o .:?! "Country" <*> (o .:?! "Country" <&> fmap Text.strip)
<*> o .:?! "StreetANDHouseNo" <*> (o .:?! "StreetANDHouseNo" <&> fmap Text.strip)
<*> o .:?! "EMail" <*> (o .:?! "EMail" <&> fmap Text.strip)
<*> o .:?! "EMailSuperior" <*> (o .:?! "EMailSuperior" <&> fmap Text.strip)
<*> o .:?! "Communication" <*> o .:?! "Communication"
instance ToJSON AvsFirmInfo where instance ToJSON AvsFirmInfo where
toJSON AvsFirmInfo{..} = object $ catMaybes toJSON AvsFirmInfo{..} = object $ catMaybes

6
src/Model/Types/Markup.hs
View File

@ -11,6 +11,7 @@ module Model.Types.Markup
, I18nStoredMarkup , I18nStoredMarkup
, markupIsSmallish , markupIsSmallish
, html2textlines , html2textlines
, isSimilarMarkup
) where ) where
import Import.NoModel import Import.NoModel
@ -51,6 +52,11 @@ data StoredMarkup = StoredMarkup
deriving (Read, Show, Generic) deriving (Read, Show, Generic)
deriving anyclass (Binary, Hashable, NFData) 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 instance Canonical (Maybe StoredMarkup) where
canonical Nothing = Nothing canonical Nothing = Nothing
canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if

4
src/Utils.hs
View File

@ -1215,6 +1215,10 @@ shortCircuitM sc binOp mx my = do
guardM :: MonadPlus m => m Bool -> m () guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f 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 :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = x >>= assertM' f assertM f x = x >>= assertM' f

154
src/Utils/Avs.hs
View File

@ -9,8 +9,8 @@ import Import.NoModel
import Utils.Lens import Utils.Lens
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map -- import qualified Data.Map as Map
import qualified Data.Text as Text -- import qualified Data.Text as Text
import Servant import Servant
import Servant.Client import Servant.Client
@ -132,7 +132,7 @@ splitQuery rawQuery q
#endif #endif
----------------------- -----------------------
-- Utility Functions -- -- Utility Functions -- DEPRECTATED
----------------------- -----------------------
-- retrieve AvsDataPersonCard with longest validity for a given licence, -- retrieve AvsDataPersonCard with longest validity for a given licence,
@ -147,87 +147,87 @@ splitQuery rawQuery q
-- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) -- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
-- | DEPRECTATED -- | DEPRECTATED
getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) -- getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
getCompanyAddress card@AvsDataPersonCard{..} -- getCompanyAddress card@AvsDataPersonCard{..}
| Just street <- avsDataStreet -- | Just street <- avsDataStreet
, Just pcode <- avsDataPostalCode -- , Just pcode <- avsDataPostalCode
, Just city <- avsDataCity -- , Just city <- avsDataCity
= (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card) -- = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card)
| isJust avsDataFirm = (avsDataFirm, Nothing, Just card) -- | isJust avsDataFirm = (avsDataFirm, Nothing, Just card)
| otherwise = (Nothing, Nothing, Nothing) -- | otherwise = (Nothing, Nothing, Nothing)
-- | From a set of card, choose the one with the most complete postal address. -- -- | 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 -- -- Returns company, postal address and the associated card where the address was taken from
guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) -- guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
guessLicenceAddress cards -- guessLicenceAddress cards
| Just c <- Set.lookupMax cards -- | Just c <- Set.lookupMax cards
, card <- Set.foldr pickLicenceAddress c cards -- , card <- Set.foldr pickLicenceAddress c cards
= getCompanyAddress card -- = getCompanyAddress card
| otherwise = (Nothing, Nothing, Nothing) -- | otherwise = (Nothing, Nothing, Nothing)
hasAddress :: AvsDataPersonCard -> Bool -- hasAddress :: AvsDataPersonCard -> Bool
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode -- hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard -- pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
pickLicenceAddress a b -- pickLicenceAddress a b
| Just r <- pickBetter' hasAddress = r -- prefer card with complete address -- | Just r <- pickBetter' hasAddress = r -- prefer card with complete address
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards -- | Just r <- pickBetter' avsDataValid = r -- prefer valid cards
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards -- | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' 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 = a -- prefer Yellow over Green, etc.
| avsDataCardColor a < avsDataCardColor b = b -- | avsDataCardColor a < avsDataCardColor b = b
| avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date -- | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
| avsDataIssueDate a < avsDataIssueDate b = b -- | avsDataIssueDate a < avsDataIssueDate b = b
| avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date -- | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
| avsDataValidTo a < avsDataValidTo b = b -- | avsDataValidTo a < avsDataValidTo b = b
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm -- | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
| a <= b = b -- respect natural Ord instance -- | a <= b = b -- respect natural Ord instance
| otherwise = a -- | otherwise = a
where -- where
pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard -- pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
pickBetter' = pickBetter a b -- pickBetter' = pickBetter a b
licenceRollfeld = licence2char AvsLicenceRollfeld -- licenceRollfeld = licence2char AvsLicenceRollfeld
licenceVorfeld = licence2char AvsLicenceVorfeld -- licenceVorfeld = licence2char AvsLicenceVorfeld
{- Note: -- {- Note:
For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so -- For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering -- bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
compare a b = compareBy avsDataValid -- compare a b = compareBy avsDataValid
<> compareBy avsDataValidTo -- <> compareBy avsDataValidTo
<> compareBy avsDataIssueDate -- <> compareBy avsDataIssueDate
... -- ...
where -- where
compareBy f = compare `on` f a b -- compareBy f = compare `on` f a b
-} -- -}
-- Merges several answers by AvsPersonId, preserving all AvsPersonCards -- -- Merges several answers by AvsPersonId, preserving all AvsPersonCards
mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -- mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
mergeByPersonId = flip $ Set.foldr aux -- mergeByPersonId = flip $ Set.foldr aux
where -- where
aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -- aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp -- aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp
catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -- catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson
catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp -- catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp
mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -- mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson
mergeAvsDataPerson = Map.unionWithKey merger -- mergeAvsDataPerson = Map.unionWithKey merger
where -- where
merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson -- merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson
merger api pa pb = -- merger api pa pb =
let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a -- let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a
pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb -- pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb
in AvsDataPerson -- in AvsDataPerson
{ avsPersonFirstName = pickBy' Text.length avsPersonFirstName -- { avsPersonFirstName = pickBy' Text.length avsPersonFirstName
, avsPersonLastName = pickBy' Text.length avsPersonLastName -- , avsPersonLastName = pickBy' Text.length avsPersonLastName
, avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo -- , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo
, avsPersonPersonNo = pickBy' id avsPersonPersonNo -- , avsPersonPersonNo = pickBy' id avsPersonPersonNo
, avsPersonPersonID = api -- keys must be identical due to call with insertWithKey -- , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey
, avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb -- , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb
} -- }
pickBy :: Ord b => (a -> b) -> a -> a -> a -- pickBy :: Ord b => (a -> b) -> a -> a -> a
pickBy f x y | f x >= f y = x -- pickBy f x y | f x >= f y = x
| otherwise = y -- | otherwise = y

38
src/Utils/DB.hs
View File

@ -326,3 +326,41 @@ instance WithRunDB backend m (ReaderT backend m) where
-- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar) -- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
-- runCachedDBRunnerUsing act getRunnerNoLock -- 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

32
src/Utils/Postal.hs Normal file
View File

@ -0,0 +1,32 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile?
-- TODO: consider merging with Handler.Utils.Users?
module Utils.Postal
( validPostAddress, validPostAddressText
) where
import Import.NoModel
import Model.Types.Markup
import Data.Char
import qualified Data.Text.Lazy as LT
-- | 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