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
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

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
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

9
src/Audit/Types.hs
View File

@ -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
}

2
src/Handler/Admin.hs
View File

@ -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}

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

@ -710,37 +710,6 @@ getAdminAvsUserR uuid = do
<p>
^{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
@ -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|
<table>
<thead>
@ -796,8 +767,10 @@ mkCardsWgt crds =
<th>_{MsgAvsCardColor}
<th>_{MsgAvsCardAreas}
<th>_{MsgTableCompany}
<th>_{MsgTableAvsCardIssueDate}
<th>_{MsgTableAvsCardValidTo}
$if hasIssueDate
<th>_{MsgTableAvsCardIssueDate}
$if hasValidToDate
<th>_{MsgTableAvsCardValidTo}
<tbody>
$forall c <- crds
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
@ -814,12 +787,14 @@ mkCardsWgt crds =
<td>
$maybe f <- avsDataFirm
#{f}
<td>
$maybe d <- avsDataIssueDate
^{formatTimeW SelFormatDate d}
<td>
$maybe d <- avsDataValidTo
^{formatTimeW SelFormatDate d}
$if hasIssueDate
<td>
$maybe d <- avsDataIssueDate
^{formatTimeW SelFormatDate d}
$if hasValidToDate
<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 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

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

@ -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

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

@ -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

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

@ -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)

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

@ -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

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

@ -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

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

@ -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

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

@ -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

4
src/Utils.hs
View File

@ -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

154
src/Utils/Avs.hs
View File

@ -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

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)
-- 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