From fdbaa3c9d4828e388bb8ef7e106ea323894d02a2 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 30 Apr 2024 17:45:29 +0200 Subject: [PATCH] chore(avs): add function to change to secondary company --- .../uniworx/categories/admin/de-de-formal.msg | 3 +- messages/uniworx/categories/admin/en-eu.msg | 3 +- src/Audit/Types.hs | 9 +- src/Handler/Admin.hs | 2 + src/Handler/Admin/Avs.hs | 55 ++---- src/Handler/Course/User.hs | 3 +- src/Handler/Utils/Avs.hs | 173 ++++++------------ src/Handler/Utils/Company.hs | 69 ++++++- src/Handler/Utils/Profile.hs | 24 +-- src/Handler/Utils/Users.hs | 21 ++- src/Jobs/Handler/QueueNotification.hs | 2 +- src/Model/Types/Avs.hs | 65 +++++-- src/Model/Types/Markup.hs | 6 + src/Utils.hs | 4 + src/Utils/Avs.hs | 154 ++++++++-------- src/Utils/DB.hs | 38 ++++ src/Utils/Postal.hs | 32 ++++ 17 files changed, 375 insertions(+), 288 deletions(-) create mode 100644 src/Utils/Postal.hs diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 70f10b233..23228c525 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -128,7 +128,8 @@ AdminProblemInfo: Problembeschreibung AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markiert AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet 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 AdminProblemUser: Betroffener ProblemTableMarkSolved: Als erledigt markieren diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 59d2e265c..34560ab2e 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -128,7 +128,8 @@ AdminProblemInfo: Problem AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened 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 AdminProblemUser: Affected ProblemTableMarkSolved: Mark done diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 1b7bf5cb8..e713b65e6 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -260,7 +260,7 @@ derivePersistFieldJSON ''Transaction -- Datatype for raising admin awareness to certain problems -- 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 = AdminProblemNewCompany -- new company was noticed, presumably without supervisors { adminProblemCompany :: CompanyId @@ -271,8 +271,13 @@ data AdminProblem , adminProblemCompanyNew :: CompanyId -- new company of the user , 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 - { 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 , adminProblemCompanyNew :: CompanyId -- new company of the user } diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index f07476330..ae4dd7aa4 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -380,6 +380,8 @@ 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} diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index cfcbd973c..d8dc325c8 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -710,37 +710,6 @@ getAdminAvsUserR uuid = do

^{cardsWgt} |] - --

- -- Vorläufige Admin Ansicht AVS Daten. - -- Ansicht zeigt aktuelle Daten. - -- Es erfolgte damit aber noch kein Update der FRADrive Daten. - --

- --

- --
InfoPersonContact
- -- (bevorzugt) - --
- -- $case mbContact - -- $of Left err - -- ^{exceptionWgt err} - -- $of Right contactInfo - -- #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))} - --
PersonStatus und mehrere PersonSearch
- -- (benötigt mehrere AVS Abfragen) - --
- -- $maybe dataPerson <- mbDataPerson - -- #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))} - -- $nothing - -- Keine Daten erhalten. - --

- -- Provisorische formatierte Ansicht - --

- -- 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} - -- |] mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget @@ -787,7 +756,9 @@ mkContactWgt warnBolt reqAvsNo AvsDataContact |] 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| @@ -796,8 +767,10 @@ mkCardsWgt crds = $forall c <- crds $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c @@ -814,12 +787,14 @@ mkCardsWgt crds =
_{MsgAvsCardColor} _{MsgAvsCardAreas} _{MsgTableCompany} - _{MsgTableAvsCardIssueDate} - _{MsgTableAvsCardValidTo} + $if hasIssueDate + _{MsgTableAvsCardIssueDate} + $if hasValidToDate + _{MsgTableAvsCardValidTo}
$maybe f <- avsDataFirm #{f} - - $maybe d <- avsDataIssueDate - ^{formatTimeW SelFormatDate d} - - $maybe d <- avsDataValidTo - ^{formatTimeW SelFormatDate d} + $if hasIssueDate + + $maybe d <- avsDataIssueDate + ^{formatTimeW SelFormatDate d} + $if hasValidToDate + + $maybe d <- avsDataValidTo + ^{formatTimeW SelFormatDate d} |] 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/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 5759f551c..ebfea411b 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -51,15 +51,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 @@ -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 ) => -- AvsPersonId -> m (Maybe AvsDataPerson) -- 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 = 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 +326,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 +352,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 +384,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 +585,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..f20089255 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -4,20 +4,21 @@ 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 -- 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 \ 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..22266d648 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,14 @@ 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] +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 +129,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 +139,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 +157,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..c1048e1e7 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. @@ -624,10 +630,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 +677,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..8cdad90a8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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..aa415efff 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -9,8 +9,8 @@ import Import.NoModel import Utils.Lens import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.Text as Text +-- import qualified Data.Map as Map +-- import qualified Data.Text as Text import Servant import Servant.Client @@ -132,7 +132,7 @@ splitQuery rawQuery q #endif ----------------------- --- Utility Functions -- +-- Utility Functions -- DEPRECTATED ----------------------- -- retrieve AvsDataPersonCard with longest validity for a given licence, @@ -147,87 +147,87 @@ 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 -mergeByPersonId = flip $ Set.foldr aux - where - aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson - aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp +-- -- Merges several answers by AvsPersonId, preserving all AvsPersonCards +-- mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson +-- mergeByPersonId = flip $ Set.foldr aux +-- where +-- aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson +-- aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp -catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp +-- catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson +-- catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp -mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -mergeAvsDataPerson = Map.unionWithKey merger - where - merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson - merger api pa pb = - let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a - pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb - in AvsDataPerson - { avsPersonFirstName = pickBy' Text.length avsPersonFirstName - , avsPersonLastName = pickBy' Text.length avsPersonLastName - , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo - , avsPersonPersonNo = pickBy' id avsPersonPersonNo - , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey - , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb - } +-- mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson +-- mergeAvsDataPerson = Map.unionWithKey merger +-- where +-- merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson +-- merger api pa pb = +-- let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a +-- pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb +-- in AvsDataPerson +-- { avsPersonFirstName = pickBy' Text.length avsPersonFirstName +-- , avsPersonLastName = pickBy' Text.length avsPersonLastName +-- , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo +-- , avsPersonPersonNo = pickBy' id avsPersonPersonNo +-- , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey +-- , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb +-- } - pickBy :: Ord b => (a -> b) -> a -> a -> a - pickBy f x y | f x >= f y = x - | otherwise = y +-- pickBy :: Ord b => (a -> b) -> a -> a -> a +-- pickBy f x y | f x >= f y = x +-- | otherwise = y 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 +-- +-- 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