^{cardsWgt} |] - --
- -- Vorläufige Admin Ansicht AVS Daten. - -- Ansicht zeigt aktuelle Daten. - -- Es erfolgte damit aber noch kein Update der FRADrive Daten. - --
- --
- -- Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. - -- In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar. - --
- -- ^{foldMap jsonWidget mbContact} - --
- -- ^{foldMap jsonWidget mbDataPerson} - -- |] 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|
| _{MsgAvsCardColor} | _{MsgAvsCardAreas} | _{MsgTableCompany} - | _{MsgTableAvsCardIssueDate} - | _{MsgTableAvsCardValidTo} + $if hasIssueDate + | _{MsgTableAvsCardIssueDate} + $if hasValidToDate + | _{MsgTableAvsCardValidTo} | $forall c <- crds $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c @@ -814,12 +787,14 @@ mkCardsWgt crds =$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 |
|---|