From fdbaa3c9d4828e388bb8ef7e106ea323894d02a2 Mon Sep 17 00:00:00 2001 From: Steffen Date: Tue, 30 Apr 2024 17:45:29 +0200 Subject: [PATCH 1/9] chore(avs): add function to change to secondary company --- .../uniworx/categories/admin/de-de-formal.msg | 3 +- messages/uniworx/categories/admin/en-eu.msg | 3 +- src/Audit/Types.hs | 9 +- src/Handler/Admin.hs | 2 + src/Handler/Admin/Avs.hs | 55 ++---- src/Handler/Course/User.hs | 3 +- src/Handler/Utils/Avs.hs | 173 ++++++------------ src/Handler/Utils/Company.hs | 69 ++++++- src/Handler/Utils/Profile.hs | 24 +-- src/Handler/Utils/Users.hs | 21 ++- src/Jobs/Handler/QueueNotification.hs | 2 +- src/Model/Types/Avs.hs | 65 +++++-- src/Model/Types/Markup.hs | 6 + src/Utils.hs | 4 + src/Utils/Avs.hs | 154 ++++++++-------- src/Utils/DB.hs | 38 ++++ src/Utils/Postal.hs | 32 ++++ 17 files changed, 375 insertions(+), 288 deletions(-) create mode 100644 src/Utils/Postal.hs diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 70f10b233..23228c525 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -128,7 +128,8 @@ AdminProblemInfo: Problembeschreibung AdminProblemsSolved n@Int: #{pluralDEeN n "Admin Probleme"} als erledigt markiert AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen -AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma +AdminProblemSupervisorNewCompany b@Bool: Dieser Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma +AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma AdminProblemUser: Betroffener ProblemTableMarkSolved: Als erledigt markieren diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 59d2e265c..34560ab2e 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -128,7 +128,8 @@ AdminProblemInfo: Problem AdminProblemsSolved n: #{pluralENsN n "admin problem"} marked as solved AdminProblemsReopened n: #{pluralENsN n "admin problem"} reopened AdminProblemNewCompany: New company from AVS; verify and add default supervisors -AdminProblemSupervisorNewCompany b: Default company supervisor #{boolText mempty "with reroute" b} changed to new company +AdminProblemSupervisorNewCompany b: This default company supervisor #{boolText mempty "with reroute" b} changed to new company +AdminProblemSupervisorLeftCompany b: Only default company supervisor #{boolText mempty "with reroute" b} for this user changed to new company AdminProblemNewlyUnsupervised: Driver has no longer a company default supervisor after AVS update at new company AdminProblemUser: Affected ProblemTableMarkSolved: Mark done diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 1b7bf5cb8..e713b65e6 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -260,7 +260,7 @@ derivePersistFieldJSON ''Transaction -- Datatype for raising admin awareness to certain problems -- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries --- Note that is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell +-- Note that there is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell dealing with special cases instead data AdminProblem = AdminProblemNewCompany -- new company was noticed, presumably without supervisors { adminProblemCompany :: CompanyId @@ -271,8 +271,13 @@ data AdminProblem , adminProblemCompanyNew :: CompanyId -- new company of the user , adminProblemSupervisorReroute :: Bool -- reroute included? } + | AdminProblemSupervisorLeftCompany + { adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to supervisor change + , adminProblemCompany :: CompanyId -- old company + , adminProblemSupervisorReroute :: Bool -- reroute included? + } | AdminProblemNewlyUnsupervised - { adminProblemUser :: UserId -- user who had supervsior but no longer has + { adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to user company change , adminProblemCompanyOld :: Maybe CompanyId -- old company , adminProblemCompanyNew :: CompanyId -- new company of the user } diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index f07476330..ae4dd7aa4 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -380,6 +380,8 @@ adminProblemCell AdminProblemNewCompany{} = i18nCell MsgAdminProblemNewCompany adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew +adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} + = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew adminProblemCell AdminProblemUnknown{adminProblemText} diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index cfcbd973c..d8dc325c8 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -710,37 +710,6 @@ getAdminAvsUserR uuid = do

^{cardsWgt} |] - --

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

- --

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

- -- Provisorische formatierte Ansicht - --

- -- Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. - -- In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar. - --

- -- ^{foldMap jsonWidget mbContact} - --

- -- ^{foldMap jsonWidget mbDataPerson} - -- |] mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget @@ -787,7 +756,9 @@ mkContactWgt warnBolt reqAvsNo AvsDataContact |] mkCardsWgt :: Set AvsDataPersonCard -> Widget -mkCardsWgt crds = +mkCardsWgt crds = do + let hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds + hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds [whamlet| @@ -796,8 +767,10 @@ mkCardsWgt crds = $forall c <- crds $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c @@ -814,12 +787,14 @@ mkCardsWgt crds =
_{MsgAvsCardColor} _{MsgAvsCardAreas} _{MsgTableCompany} - _{MsgTableAvsCardIssueDate} - _{MsgTableAvsCardValidTo} + $if hasIssueDate + _{MsgTableAvsCardIssueDate} + $if hasValidToDate + _{MsgTableAvsCardValidTo}
$maybe f <- avsDataFirm #{f} - - $maybe d <- avsDataIssueDate - ^{formatTimeW SelFormatDate d} - - $maybe d <- avsDataValidTo - ^{formatTimeW SelFormatDate d} + $if hasIssueDate + + $maybe d <- avsDataIssueDate + ^{formatTimeW SelFormatDate d} + $if hasValidToDate + + $maybe d <- avsDataValidTo + ^{formatTimeW SelFormatDate d} |] diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index b24dfd744..81af8b6e4 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -9,12 +9,11 @@ module Handler.Course.User import Import import Utils.Form +import Utils.Mail (pickValidUserEmail) import Handler.Utils import Handler.Utils.SheetType -import Handler.Utils.Profile (pickValidUserEmail) import Handler.Utils.StudyFeatures import Handler.Submission.List - import Handler.Course.Register import Jobs.Queue diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 5759f551c..ebfea411b 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -51,15 +51,12 @@ import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionExce import Jobs.Queue import Utils.Avs -import Utils.Mail (pickValidEmail) import Utils.Users import Handler.Utils.Users -import Handler.Utils.Profile (validPostAddressText) import Handler.Utils.Company import Handler.Utils.Qualification import Handler.Utils.Memcached -import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E @@ -140,7 +137,7 @@ catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHan ------------------ --- TODO: delete lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored! +-- TODO: delete deprecated Utility Functions from Utils.Avs as well -- lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => -- AvsPersonId -> m (Maybe AvsDataPerson) -- lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) @@ -276,76 +273,9 @@ queryAvsPrimaryCard api = runMaybeT $ do queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo) queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard -_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) -_avsFirmPostAddress = to mkPost - where - mkPost afi@AvsFirmInfo{avsFirmFirm} = - let someAddr = afi ^. _avsFirmPostAddressSimple - prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n' - in prefAddr <$> someAddr - --- | company post address without company name, better suited for comparisons -_avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) -_avsFirmPostAddressSimple = to mkPost - where - mkPost AvsFirmInfo{..} = - let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry - commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress - in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] - -_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) -_avsFirmPrimaryEmail = to mkEmail - where - mkEmail afi = - let candidates = catMaybes - [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail - , afi ^. _avsFirmEMailSuperior - , afi ^. _avsFirmEMail - ] - in pickValidEmail candidates -- should we return an invalid email rather than none? - --- | Not sure this is useful, since postal is ignored if there is no post address anyway -_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool -_avsFirmPrefersPostal = to mkPostPref - where - mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail) --- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens -data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting --- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value, --- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query -mkUpdate :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) -mkUpdate ent new (Just old) (CheckAvsUpdate up l) - | let newval = new ^. l - , let oldval = old ^. l - , let entval = ent ^. fieldLensVal up - , newval /= entval - , oldval == entval - = Just (up =. newval) -mkUpdate _ _ _ _ = Nothing - --- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited -mkUpdate' :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) -mkUpdate' ent new Nothing = mkUpdateDirect ent new -mkUpdate' ent new just = mkUpdate ent new just - -mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record) -mkUpdateDirect ent new (CheckAvsUpdate up l) - | let newval = new ^. l - , let entval = ent ^. fieldLensVal up - , newval /= entval - = Just (up =. newval) -mkUpdateDirect _ _ _ = Nothing - --- | Unconditionally update a record through CheckAvsU -updateRecord :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> record -updateRecord ent new (CheckAvsUpdate up l) = - let newval = new ^. l - lensRec = fieldLensVal up - in ent & lensRec .~ newval - -- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks updateAvsUserById :: AvsPersonId -> DB (Maybe UserId) updateAvsUserById apid = do @@ -396,23 +326,23 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here oldAvsCardNo = userAvsLastCardNo usravs & fmap Just per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) - [ CheckAvsUpdate UserFirstName _avsInfoFirstName - , CheckAvsUpdate UserSurname _avsInfoLastName - , CheckAvsUpdate UserDisplayName _avsInfoDisplayName - , CheckAvsUpdate UserBirthday _avsInfoDateOfBirth - , CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo - , CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` - , CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo + [ CheckUpdate UserFirstName _avsInfoFirstName + , CheckUpdate UserSurname _avsInfoLastName + , CheckUpdate UserDisplayName _avsInfoDisplayName + , CheckUpdate UserBirthday _avsInfoDateOfBirth + , CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo + , CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` + , CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo ] em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $ - CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User + CheckUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User em_f_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. - CheckAvsUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI + CheckUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users, - CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead + CheckUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card - CheckAvsUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just + CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups)) avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` [ UserAvsLastSynch =. now @@ -422,27 +352,27 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa , UserAvsLastCardNo =. newAvsCardNo ] -- update company association & supervision - Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo + Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo - primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand) + primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId let oldCompanyId = entityKey <$> oldCompanyEnt - oldCompanyMb = entityVal <$> oldCompanyEnt - pst_up = if - -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines - -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) - | isNothing oldCompanyMb - -> mkUpdateDirect usr newCompany $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) - | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line - -> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference - | otherwise - -> Nothing + -- oldCompanyMb = entityVal <$> oldCompanyEnt + -- pst_up = if + -- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines + -- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) + -- | isNothing oldCompanyMb + -- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) + -- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line + -- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference + -- | otherwise + -- -> Nothing superReasonComDef = tshow SupervisorReasonCompanyDefault newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done usr_up2 <- case oldAvsFirmInfo of _ | Just newCompanyId == oldCompanyId -- company unchanged entirely - -> return Nothing -- => do nothing + -> return mempty -- => do nothing (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR || ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged -> do -- => just update user company association, keeping supervision privileges @@ -454,31 +384,39 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa , UserSupervisorCompany ==. Just ocid -- to new company, regardless of , UserSupervisorReason ==. Just superReasonComDef] -- user [ UserSupervisorCompany =. Just newCompanyId] - return Nothing + return mempty _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company -> do whenIsJust oldCompanyId $ \oldCid -> do deleteBy $ UniqueUserCompany usrId oldCid deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) - return Nothing + return mempty _ -- company changed completely -> do - -- switch user company, keeping old priority - (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case - Nothing -> - void $ insertUnique newUserComp - Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do - when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute - delete ucidOld - void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds - -- adjust supervison - oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] - addCompanySupervisors newCompanyId usrId - newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) - when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId + (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId + mapM_ reportAdminProblem problems + -- Following line does not type, hence additional parameter needed + -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates) return pst_up + -- SPECIALISED CODE, PROBABLY DEPRECATED + -- switch user company, keeping old priority + -- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case + -- Nothing -> + -- void $ insertUnique newUserComp + -- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do + -- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute + -- delete ucidOld + -- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds + -- -- adjust supervison + -- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef] + -- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr + -- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr + -- addCompanySupervisors newCompanyId usrId + -- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef) + -- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId + -- return pst_up repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors - update usrId $ usr_up2 `mcons` usr_up1 -- update user eventually + update usrId $ usr_up2 <> usr_up1 -- update user eventually update uaId avs_ups -- update stored avsinfo for future updates return (apid, usrId) @@ -647,15 +585,16 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do where firmInfo2company = - [ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI - , CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI - , CheckAvsUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade - -- , CheckAvsUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available - , CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress - , CheckAvsUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just + [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI + , CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI + , CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade + -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available + , CheckUpdate CompanyPostAddress _avsFirmPostAddress + , CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just ] + queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler () queueAvsUpdateByUID uids pause = do now <- liftIO getCurrentTime diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 1c13fd5fd..f20089255 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -4,20 +4,21 @@ module Handler.Utils.Company where + import Import --- import Utils.PathPiece -- import Data.CaseInsensitive (CI) -- import qualified Data.CaseInsensitive as CI -- import qualified Data.Char as Char -- import qualified Data.Text as Text --- import Database.Persist.Postgresql +import Database.Persist.Postgresql -- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.PostgreSQL as E +import Handler.Utils.Users -- TODO: use this function in company view Handler.Firm #157 @@ -44,3 +45,67 @@ addCompanySupervisors cid uid = ] ) + +-- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet +switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem]) +switchAvsUserCompany usrPostAddrUpd keepOldCompanySupervs uid newCompanyId = do + usrRec <- get404 uid + newCompany <- get404 newCompanyId + mbUsrComp <- getUserPrimaryCompany uid + mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp + mbUsrAvs <- if usrPostAddrUpd then getBy (UniqueUserAvsUser uid) else return Nothing + let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec + avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just + usrPostUp = toMaybe (usrPostAddrUpd && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr)) + (UserPostAddress =. Nothing) -- use company address indirectyl instead + usrPrefPost = userPrefersPostal usrRec + usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal)) + (UserPrefersPostal =. companyPrefersPostal newCompany) + usrUpdate = catMaybes [usrPostUp, usrPrefPostUp] + -- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional + -- update uid usrUpdate + -- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association + case mbUsrComp of + Nothing -> do -- create company user + void $ insertUnique newUserComp + addCompanySupervisors newCompanyId uid + return (usrUpdate, mempty) + Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute} + | newCompanyId == oldCompanyId -> return mempty -- nothing to do + | otherwise -> do -- switch company + void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp + [UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True] + -- supervised by uid + supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do + usrSup <- E.from $ E.table @UserSupervisor + E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid + E.&&. usrSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId + E.&&. usrSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef + let singleSup = E.notExists $ do + othSup <- E.from $ E.table @UserSupervisor + E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser + E.&&. othSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId + E.&&. othSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef + return (usrSup, singleSup) + newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do + E.delete $ do + usrSup <- E.from $ E.table @UserSupervisor + E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees) + return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute + | (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ] + -- supervisors of uid + let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef) + oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr + oldAPs <- if keepOldCompanySupervs + then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing] + else deleteWhereCount oldSubFltr + addCompanySupervisors newCompanyId uid + newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr + let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0 + problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute) + $ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId) + newlyUnsupervised + return (usrUpdate ,problems) + where + newUserComp = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done + superReasonComDef = tshow SupervisorReasonCompanyDefault \ No newline at end of file diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 6072a5b2f..782cd02b1 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -6,22 +6,19 @@ -- TODO: consider merging with Handler.Utils.Users? module Handler.Utils.Profile ( module Utils.Mail + , module Utils.Postal , validDisplayName, checkDisplayName, fixDisplayName - , validPostAddress, validPostAddressText , validFraportPersonalNumber ) where import Import.NoFoundation -import Data.Char import qualified Data.Text as Text -import qualified Data.Text.Lazy as LT --- import qualified Data.CaseInsensitive as CI - import qualified Data.MultiSet as MultiSet import qualified Data.Set as Set import Utils.Mail +import Utils.Postal -- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname". -- Input "givennames surname" is left unchanged, except for removing excess whitespace @@ -63,23 +60,6 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s splitAdd = Text.split isAdd makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd - --- | Primitive postal address requires at least one alphabetic character, one digit and a line break -validPostAddress :: Maybe StoredMarkup -> Bool -validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr -validPostAddress _ = False - -validPostAddressText :: Text -> Bool -validPostAddressText = validPostAddressLazyText . LT.fromStrict - -validPostAddressLazyText :: LT.Text -> Bool -validPostAddressLazyText addr - | Just _ <- LT.find isLetter addr - , Just _ <- LT.find isNumber addr - -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK - = 1 < length (LT.lines addr) -validPostAddressLazyText _ = False - validFraportPersonalNumber :: Maybe Text -> Bool validFraportPersonalNumber Nothing = False validFraportPersonalNumber (Just t) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 9e39ca041..22266d648 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -15,7 +15,7 @@ module Handler.Utils.Users , guessUser, guessUserByEmail , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser - , getUserPrimaryCompany + , getUserPrimaryCompany, getUserPrimaryCompanyAddress , getUserEmail , getEmailAddress, getJustEmailAddress , getEmailAddressFor, getJustEmailAddressFor @@ -76,11 +76,14 @@ abbrvName User{userDisplayName, userFirstName, userSurname} = assemble = Text.intercalate "." -getUserPrimaryCompany :: UserId -> (Company -> Maybe a) -> DB (Maybe a) -getUserPrimaryCompany uid prj = runMaybeT $ do - Entity{entityVal=UserCompany{userCompanyCompany=cid}} <- MaybeT $ - selectFirst [UserCompanyUser ==. uid, UserCompanyUseCompanyAddress ==. True] - [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany] +getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany) +getUserPrimaryCompany uid = entityVal <<$>> + selectFirst [UserCompanyUser ==. uid] + [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany] + +getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DB (Maybe a) +getUserPrimaryCompanyAddress uid prj = runMaybeT $ do + UserCompany{userCompanyCompany=cid, userCompanyUseCompanyAddress=True} <- MaybeT $ getUserPrimaryCompany uid -- return Nothing if company address is not to be used company <- MaybeT $ get cid -- hoistMaybe $ prj company MaybeT $ pure $ prj company @@ -126,7 +129,7 @@ getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}} = return $ Just userDisplayEmail | otherwise = do - compEmailMb <- getUserPrimaryCompany uid companyEmail + compEmailMb <- getUserPrimaryCompanyAddress uid companyEmail return $ pickValidEmail' $ mcons compEmailMb [userEmail] -- address is prefixed with userDisplayName @@ -136,7 +139,7 @@ getPostalAddress Entity{entityKey=uid, entityVal=User{..}} = prefixMarkupName pa | otherwise = do - getUserPrimaryCompany uid companyPostAddress >>= \case + getUserPrimaryCompanyAddress uid companyPostAddress >>= \case (Just pa) -> prefixMarkupName pa Nothing @@ -154,7 +157,7 @@ getPostalAddress' Entity{entityKey=uid, entityVal=User{..}} = return res | otherwise = do - getUserPrimaryCompany uid companyPostAddress >>= \case + getUserPrimaryCompanyAddress uid companyPostAddress >>= \case res@(Just _) -> return res Nothing diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index fb1b0f75b..12abd0c4d 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -16,7 +16,7 @@ import Jobs.Queue import qualified Data.Set as Set --- import Handler.Utils.Profile (pickValidUserEmail') +-- import Utils.Mail (pickValidUserEmail') import Handler.Utils.Users (getUserEmail) import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.ExternalExam diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index f3dd0e507..c1048e1e7 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -12,6 +12,9 @@ module Model.Types.Avs ) where import Import.NoModel hiding ((.=)) + +import Model.Types.Markup + import Database.Persist.Sql import qualified Database.Esqueleto.Experimental as E import qualified Data.Csv as Csv @@ -27,6 +30,9 @@ import qualified Data.Set as Set import Data.Aeson import Data.Aeson.Types as Aeson +import Utils.Postal (validPostAddressText) +import Utils.Mail (pickValidEmail) + {- -- | Like (.:) but attempts parsing with case-insensitve keys as fallback. @@ -624,10 +630,41 @@ data AvsFirmInfo = AvsFirmInfo } deriving (Eq, Ord, Show, Generic, NFData, Binary) makeLenses_ ''AvsFirmInfo --- additional convenience lenses declared in Handler.Utils.Avs due to required dependencies: --- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) --- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool --- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +-- additional convenience lenses: + +_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup) +_avsFirmPostAddress = to mkPost + where + mkPost afi@AvsFirmInfo{avsFirmFirm} = + let someAddr = afi ^. _avsFirmPostAddressSimple + prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n' + in prefAddr <$> someAddr + +-- | company post address without company name, better suited for comparisons +_avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +_avsFirmPostAddressSimple = to mkPost + where + mkPost AvsFirmInfo{..} = + let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry + commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress + in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr] + +_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) +_avsFirmPrimaryEmail = to mkEmail + where + mkEmail afi = + let candidates = catMaybes + [ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail + , afi ^. _avsFirmEMailSuperior + , afi ^. _avsFirmEMail + ] + in pickValidEmail candidates -- should we return an invalid email rather than none? + +-- | Not sure this is useful, since postal is ignored if there is no post address anyway +_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool +_avsFirmPrefersPostal = to mkPostPref + where + mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail) -- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead -- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text @@ -640,16 +677,16 @@ makeLenses_ ''AvsFirmInfo instance FromJSON AvsFirmInfo where parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo - <$> (o .: "Firm" <&> Text.strip) -- AVS may contain leading/trailing whitespace - <*> o .: "FirmNo" - <*> (o .: "Abbreviation" <&> Text.strip) -- AVS may contain leading/trailing whitespace - <*> o .:?! "ZIPCode" - <*> o .:?! "City" - <*> o .:?! "Country" - <*> o .:?! "StreetANDHouseNo" - <*> o .:?! "EMail" - <*> o .:?! "EMailSuperior" - <*> o .:?! "Communication" + <$> (o .: "Firm" <&> Text.strip) -- AVS often contains leading/trailing whitespace + <*> o .: "FirmNo" + <*> (o .: "Abbreviation" <&> Text.strip) + <*> (o .:?! "ZIPCode" <&> fmap Text.strip) + <*> (o .:?! "City" <&> fmap Text.strip) + <*> (o .:?! "Country" <&> fmap Text.strip) + <*> (o .:?! "StreetANDHouseNo" <&> fmap Text.strip) + <*> (o .:?! "EMail" <&> fmap Text.strip) + <*> (o .:?! "EMailSuperior" <&> fmap Text.strip) + <*> o .:?! "Communication" instance ToJSON AvsFirmInfo where toJSON AvsFirmInfo{..} = object $ catMaybes diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index b2a22915d..a250927c4 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -11,6 +11,7 @@ module Model.Types.Markup , I18nStoredMarkup , markupIsSmallish , html2textlines + , isSimilarMarkup ) where import Import.NoModel @@ -51,6 +52,11 @@ data StoredMarkup = StoredMarkup deriving (Read, Show, Generic) deriving anyclass (Binary, Hashable, NFData) +isSimilarMarkup :: StoredMarkup -> StoredMarkup -> Bool +isSimilarMarkup StoredMarkup{markupInputFormat=af, markupInput=ai} + StoredMarkup{markupInputFormat=bf, markupInput=bi} + = af==bf && ai == bi + instance Canonical (Maybe StoredMarkup) where canonical Nothing = Nothing canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if diff --git a/src/Utils.hs b/src/Utils.hs index 3ac9fb955..8cdad90a8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1215,6 +1215,10 @@ shortCircuitM sc binOp mx my = do guardM :: MonadPlus m => m Bool -> m () guardM f = guard =<< f +guardMonoidM :: (Applicative f, Monoid m) => Bool -> f m -> f m +guardMonoidM False _ = pure mempty +guardMonoidM True x = x + assertM :: MonadPlus m => (a -> Bool) -> m a -> m a assertM f x = x >>= assertM' f diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index a9bbdfb66..aa415efff 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -9,8 +9,8 @@ import Import.NoModel import Utils.Lens import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.Text as Text +-- import qualified Data.Map as Map +-- import qualified Data.Text as Text import Servant import Servant.Client @@ -132,7 +132,7 @@ splitQuery rawQuery q #endif ----------------------- --- Utility Functions -- +-- Utility Functions -- DEPRECTATED ----------------------- -- retrieve AvsDataPersonCard with longest validity for a given licence, @@ -147,87 +147,87 @@ splitQuery rawQuery q -- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) -- | DEPRECTATED -getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) -getCompanyAddress card@AvsDataPersonCard{..} - | Just street <- avsDataStreet - , Just pcode <- avsDataPostalCode - , Just city <- avsDataCity - = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card) - | isJust avsDataFirm = (avsDataFirm, Nothing, Just card) - | otherwise = (Nothing, Nothing, Nothing) +-- getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) +-- getCompanyAddress card@AvsDataPersonCard{..} +-- | Just street <- avsDataStreet +-- , Just pcode <- avsDataPostalCode +-- , Just city <- avsDataCity +-- = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card) +-- | isJust avsDataFirm = (avsDataFirm, Nothing, Just card) +-- | otherwise = (Nothing, Nothing, Nothing) --- | From a set of card, choose the one with the most complete postal address. --- Returns company, postal address and the associated card where the address was taken from -guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) -guessLicenceAddress cards - | Just c <- Set.lookupMax cards - , card <- Set.foldr pickLicenceAddress c cards - = getCompanyAddress card - | otherwise = (Nothing, Nothing, Nothing) +-- -- | From a set of card, choose the one with the most complete postal address. +-- -- Returns company, postal address and the associated card where the address was taken from +-- guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) +-- guessLicenceAddress cards +-- | Just c <- Set.lookupMax cards +-- , card <- Set.foldr pickLicenceAddress c cards +-- = getCompanyAddress card +-- | otherwise = (Nothing, Nothing, Nothing) -hasAddress :: AvsDataPersonCard -> Bool -hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode +-- hasAddress :: AvsDataPersonCard -> Bool +-- hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode -pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard -pickLicenceAddress a b - | Just r <- pickBetter' hasAddress = r -- prefer card with complete address - | Just r <- pickBetter' avsDataValid = r -- prefer valid cards - | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards - | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards - | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc. - | avsDataCardColor a < avsDataCardColor b = b - | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date - | avsDataIssueDate a < avsDataIssueDate b = b - | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date - | avsDataValidTo a < avsDataValidTo b = b - | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm - | a <= b = b -- respect natural Ord instance - | otherwise = a - where - pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard - pickBetter' = pickBetter a b - licenceRollfeld = licence2char AvsLicenceRollfeld - licenceVorfeld = licence2char AvsLicenceVorfeld +-- pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard +-- pickLicenceAddress a b +-- | Just r <- pickBetter' hasAddress = r -- prefer card with complete address +-- | Just r <- pickBetter' avsDataValid = r -- prefer valid cards +-- | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards +-- | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards +-- | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc. +-- | avsDataCardColor a < avsDataCardColor b = b +-- | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date +-- | avsDataIssueDate a < avsDataIssueDate b = b +-- | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date +-- | avsDataValidTo a < avsDataValidTo b = b +-- | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm +-- | a <= b = b -- respect natural Ord instance +-- | otherwise = a +-- where +-- pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard +-- pickBetter' = pickBetter a b +-- licenceRollfeld = licence2char AvsLicenceRollfeld +-- licenceVorfeld = licence2char AvsLicenceVorfeld -{- Note: -For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so -bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering - compare a b = compareBy avsDataValid - <> compareBy avsDataValidTo - <> compareBy avsDataIssueDate - ... - where - compareBy f = compare `on` f a b --} +-- {- Note: +-- For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so +-- bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering +-- compare a b = compareBy avsDataValid +-- <> compareBy avsDataValidTo +-- <> compareBy avsDataIssueDate +-- ... +-- where +-- compareBy f = compare `on` f a b +-- -} --- Merges several answers by AvsPersonId, preserving all AvsPersonCards -mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -mergeByPersonId = flip $ Set.foldr aux - where - aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson - aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp +-- -- Merges several answers by AvsPersonId, preserving all AvsPersonCards +-- mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson +-- mergeByPersonId = flip $ Set.foldr aux +-- where +-- aux :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson +-- aux adp = mergeAvsDataPerson $ catalogueAvsDataPerson adp -catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson -catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp +-- catalogueAvsDataPerson :: AvsDataPerson -> Map AvsPersonId AvsDataPerson +-- catalogueAvsDataPerson adp = Map.singleton (avsPersonPersonID adp) adp -mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -mergeAvsDataPerson = Map.unionWithKey merger - where - merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson - merger api pa pb = - let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a - pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb - in AvsDataPerson - { avsPersonFirstName = pickBy' Text.length avsPersonFirstName - , avsPersonLastName = pickBy' Text.length avsPersonLastName - , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo - , avsPersonPersonNo = pickBy' id avsPersonPersonNo - , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey - , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb - } +-- mergeAvsDataPerson :: Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson +-- mergeAvsDataPerson = Map.unionWithKey merger +-- where +-- merger :: AvsPersonId -> AvsDataPerson -> AvsDataPerson -> AvsDataPerson +-- merger api pa pb = +-- let pickBy' :: Ord b => (a -> b) -> (AvsDataPerson -> a) -> a +-- pickBy' f p = pickBy f (p pa) (p pb) -- pickBy f `on` p pa pb +-- in AvsDataPerson +-- { avsPersonFirstName = pickBy' Text.length avsPersonFirstName +-- , avsPersonLastName = pickBy' Text.length avsPersonLastName +-- , avsPersonInternalPersonalNo = pickBy' (maybe 0 length) avsPersonInternalPersonalNo +-- , avsPersonPersonNo = pickBy' id avsPersonPersonNo +-- , avsPersonPersonID = api -- keys must be identical due to call with insertWithKey +-- , avsPersonPersonCards = (Set.union `on` avsPersonPersonCards) pa pb +-- } - pickBy :: Ord b => (a -> b) -> a -> a -> a - pickBy f x y | f x >= f y = x - | otherwise = y +-- pickBy :: Ord b => (a -> b) -> a -> a -> a +-- pickBy f x y | f x >= f y = x +-- | otherwise = y diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index fdad68adf..1bbadb1f6 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -326,3 +326,41 @@ instance WithRunDB backend m (ReaderT backend m) where -- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar) -- runCachedDBRunnerUsing act getRunnerNoLock + + + +-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens +data CheckUpdate record iraw = forall typ. (Eq typ, PersistField typ) => CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting + + +-- | Compute necessary updates. Given a database record, the new and old raw data, and a pair consisting of a getter from raw data to a value and an EntityField of the same value, +-- an update is returned, if the current value is identical to the old value, which changed in the new raw data +mkUpdate :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record) +mkUpdate ent new (Just old) (CheckUpdate up l) + | let newval = new ^. l + , let oldval = old ^. l + , let entval = ent ^. fieldLensVal up + , newval /= entval + , oldval == entval + = Just (up =. newval) +mkUpdate _ _ _ _ = Nothing + +-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited +mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record) +mkUpdate' ent new Nothing = mkUpdateDirect ent new +mkUpdate' ent new just = mkUpdate ent new just + +mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record) +mkUpdateDirect ent new (CheckUpdate up l) + | let newval = new ^. l + , let entval = ent ^. fieldLensVal up + , newval /= entval + = Just (up =. newval) +mkUpdateDirect _ _ _ = Nothing + +-- | Unconditionally update a record through ChecUpdate +updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record +updateRecord ent new (CheckUpdate up l) = + let newval = new ^. l + lensRec = fieldLensVal up + in ent & lensRec .~ newval \ No newline at end of file diff --git a/src/Utils/Postal.hs b/src/Utils/Postal.hs new file mode 100644 index 000000000..65c7b2d0a --- /dev/null +++ b/src/Utils/Postal.hs @@ -0,0 +1,32 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? +-- TODO: consider merging with Handler.Utils.Users? +module Utils.Postal + ( validPostAddress, validPostAddressText + ) where + +import Import.NoModel +import Model.Types.Markup + +import Data.Char +import qualified Data.Text.Lazy as LT + + +-- | Primitive postal address requires at least one alphabetic character, one digit and a line break +validPostAddress :: Maybe StoredMarkup -> Bool +validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr +validPostAddress _ = False + +validPostAddressText :: Text -> Bool +validPostAddressText = validPostAddressLazyText . LT.fromStrict + +validPostAddressLazyText :: LT.Text -> Bool +validPostAddressLazyText addr + | Just _ <- LT.find isLetter addr + , Just _ <- LT.find isNumber addr + -- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK + = 1 < length (LT.lines addr) +validPostAddressLazyText _ = False From 5944efcb869f605c7d2c855b766ba5fd1e265019 Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 2 May 2024 17:28:59 +0200 Subject: [PATCH 2/9] chore(avs): change to secondary company (WIP) form missing --- .../uniworx/categories/user/de-de-formal.msg | 7 +- messages/uniworx/categories/user/en-eu.msg | 9 +- src/Handler/Admin/Avs.hs | 263 ++++++++++-------- src/Handler/Users.hs | 24 +- src/Handler/Utils/Avs.hs | 48 ++-- src/Handler/Utils/Users.hs | 1 + src/Model/Types/Avs.hs | 3 + src/Utils/Avs.hs | 56 ++-- 8 files changed, 240 insertions(+), 171 deletions(-) diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 573892220..a5447bd65 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -37,7 +37,8 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an UsersCourseSchool: Bereich ActionNoUsersSelected: Keine Benutzer:innen ausgewählt -SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen +SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen +SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen UserListTitle: Komprehensive Benutzerliste @@ -89,12 +90,14 @@ NewPasswordLink: Neues Passwort setzen UserAccountDeleteWarning: Achtung, dies löscht den kompletten Benutzer/die komplette Benutzerin unwiderruflich und mit allen assoziierten Daten aus der Datenbank. Prüfungsdaten müssen jedoch langfristig gespeichert bleiben! UserAvsSync: AVS-Synchronisieren UserLdapSync: LDAP-Synchronisieren -AllUsersLdapSync: Alle LDAP-Synchronisieren UserHijack: Sitzung übernehmen UserAddSupervisor: Ansprechpartner hinzufügen UserSetSupervisor: Ansprechpartner ersetzen UserRemoveSupervisor: Alle Ansprechpartner entfernen UserIsSupervisor: Ist Ansprechpartner +UserAvsSwitchCompany: Als Primärfirma verwenden +AllUsersLdapSync: Alle LDAP-Synchronisieren +AllUsersAvsSync: Alle AVS-Synchronisieren AuthKindLDAP: Fraport AG Kennung AuthKindPWHash: FRADrive Kennung AuthKindNoLogin: Kein Login möglich diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 43bc1bf85..dbad43215 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -37,8 +37,9 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific AuthPWHashConfigured: User now logs in using their FRADrive specific account UsersCourseSchool: Department ActionNoUsersSelected: No users selected -SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}. -SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}. +SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"} +SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today +SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"} SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users UserListTitle: Comprehensive list of users AccessRightsSaved: Successfully updated permissions @@ -89,12 +90,14 @@ NewPasswordLink: Set password UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term! UserAvsSync: Synchronise with AVS UserLdapSync: Synchronise with LDAP -AllUsersLdapSync: Synchronise all with LDAP UserHijack: Hijack session UserAddSupervisor: Add supervisor UserSetSupervisor: Replace supervisors UserRemoveSupervisor: Set to unsupervised UserIsSupervisor: Is supervisor +UserAvsSwitchCompany: Use as primary company +AllUsersLdapSync: Synchronise all with LDAP +AllUsersAvsSync: Synchronise all with AVS AuthKindLDAP: Fraport AG account AuthKindPWHash: FRADrive account AuthKindNoLogin: No login diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index d8dc325c8..0cb2fa130 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -27,7 +27,7 @@ import qualified Data.Map as Map import Handler.Utils import Handler.Utils.Avs -- import Handler.Utils.Qualification - +import Handler.Utils.Users (getUserPrimaryCompany) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as E @@ -676,126 +676,157 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do +data UserAvsAction = UserAvsSwitchCompany + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''UserAvsAction id + +data UserAvsActionData = UserAvsSwitchCompanyData { getAvsUser :: UserId, getAvsCompany :: CompanyId } + deriving (Eq, Ord, Read, Show, Generic) + getAdminAvsUserR :: CryptoUUIDUser -> Handler Html getAdminAvsUserR uuid = do - uid <- decrypt uuid - Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid - mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId - mbStatus <- try $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId - -- mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed - - msgWarningTooltip <- messageI Warning MsgMessageWarning - let warnBolt = messageTooltip msgWarningTooltip - heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|] - siteLayout heading $ do - setTitle $ toHtml $ show userAvsNoPerson - let contactWgt = case mbContact of - Left err -> exceptionWgt err - Right (AvsResponseContact adcs) -> do - let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs - mconcat cs - cardsWgt = case mbStatus of - Left err -> exceptionWgt err - Right (AvsResponseStatus asts) -> do - let cs = mkCardsWgt . avsStatusPersonCardStatus <$> toList asts - mconcat cs - -- cardsWgt = case mbDataPerson of - -- Nothing -> mempty - -- Just AvsDataPerson{avsPersonPersonCards=crds} -> mkCardsWgt crds - [whamlet| -

- Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten: -

- ^{contactWgt} -

- ^{cardsWgt} - |] + uid <- decrypt uuid + Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid + -- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic + let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID)) + -- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID)) + mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId + -- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId + mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses + compDict <- runDB $ do + mbPrimeComp <- getUserPrimaryCompany uid + let (primeName, fltrPrimary) = maybeEmpty mbPrimeComp $ \Company{companyName=pName, companyShorthand=pShort} -> (pName, [CompanyShorthand !=. pShort]) + compsUsed :: [Text] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just + fltrCmps = (CompanyName <-. compsUsed) : fltrPrimary + comps <- selectList fltrCmps [Asc CompanyName] -- company name is unique + return (primeName, Map.fromAscList [(cname,cid) | (Entity{entityKey=cid, entityVal=Company{companyName=cname}}) <- comps]) -mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget -mkContactWgt warnBolt reqAvsNo AvsDataContact - { -- avsContactPersonID = _api - avsContactPersonInfo = AvsPersonInfo{..} - , avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName } - } = - let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in - [whamlet| -

-
- $if avsNoOk -
- _{MsgAvsPersonNo} -
- #{avsInfoPersonNo} - ^{warnBolt} - _{MsgAvsPersonNoMismatch} -
- _{MsgAvsLastName} -
- #{avsInfoLastName} -
- _{MsgAvsFirstName} -
- #{avsInfoFirstName} -
- _{MsgAvsPrimaryCompany} -
- #{firmName} - $maybe bday <- avsInfoDateOfBirth -
- _{MsgAdminUserBirthday} -
- ^{formatTimeW SelFormatDate bday} -
- _{MsgAvsLicence} -
- $maybe licence <- parseAvsLicence avsInfoRampLicence - _{licence} - $nothing - _{MsgAvsNoLicenceGuest} - |] + msgWarningTooltip <- messageI Warning MsgMessageWarning + let warnBolt = messageTooltip msgWarningTooltip + heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|] + siteLayout heading $ do + setTitle $ toHtml $ show userAvsNoPerson + let contactWgt = case mbContact of + Left err -> exceptionWgt err + Right (AvsResponseContact adcs) -> do + let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs + mconcat cs + cardsWgt = case mbStatus of + Left err -> exceptionWgt err + Right (AvsResponseStatus asts) -> do + let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts + mconcat cs + -- cardsWgt = case mbDataPerson of + -- Nothing -> mempty + -- Just AvsDataPerson{avsPersonPersonCards=crds} -> mkCardsWgt crds + [whamlet| +

+ Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten: +

+ ^{contactWgt} +

+ ^{cardsWgt} + |] + where + mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget + mkContactWgt warnBolt reqAvsNo AvsDataContact + { -- avsContactPersonID = _api + avsContactPersonInfo = AvsPersonInfo{..} + , avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName } + } = + let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in + [whamlet| +

+
+ $if avsNoOk +
+ _{MsgAvsPersonNo} +
+ #{avsInfoPersonNo} + ^{warnBolt} + _{MsgAvsPersonNoMismatch} +
+ _{MsgAvsLastName} +
+ #{avsInfoLastName} +
+ _{MsgAvsFirstName} +
+ #{avsInfoFirstName} +
+ _{MsgAvsPrimaryCompany} +
+ #{firmName} + $maybe bday <- avsInfoDateOfBirth +
+ _{MsgAdminUserBirthday} +
+ ^{formatTimeW SelFormatDate bday} +
+ _{MsgAvsLicence} +
+ $maybe licence <- parseAvsLicence avsInfoRampLicence + _{licence} + $nothing + _{MsgAvsNoLicenceGuest} + |] -mkCardsWgt :: Set AvsDataPersonCard -> Widget -mkCardsWgt crds = do - let hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds - hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds - [whamlet| - - - - $forall c <- crds - $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c - -
_{MsgAvsCardNo} - _{MsgTableAvsCardValid} - _{MsgAvsCardColor} - _{MsgAvsCardAreas} - _{MsgTableCompany} - $if hasIssueDate - _{MsgTableAvsCardIssueDate} - $if hasValidToDate - _{MsgTableAvsCardValidTo} -
- #{tshowAvsFullCardNo (getFullCardNo c)} - - #{boolSymbol avsDataValid} - - _{avsDataCardColor} - - $forall a <- avsDataCardAreas - #{a} # - - $maybe f <- avsDataFirm - #{f} - $if hasIssueDate - - $maybe d <- avsDataIssueDate - ^{formatTimeW SelFormatDate d} - $if hasValidToDate - - $maybe d <- avsDataValidTo - ^{formatTimeW SelFormatDate d} - |] + mkCardsWgt :: (Maybe CompanyName, Map CompanyName CompanyId) -> Set AvsDataPersonCard -> Widget + mkCardsWgt (primName, compDict) crds = do + let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does + hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds + hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds + [whamlet| + + + + $forall c <- crds + $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c + +
_{MsgAvsCardNo} + _{MsgTableAvsCardValid} + _{MsgAvsCardColor} + _{MsgAvsCardAreas} + $if hasIssueDate + _{MsgTableAvsCardIssueDate} + $if hasValidToDate + _{MsgTableAvsCardValidTo} + $if hasCompany + _{MsgTableCompany} + +
+ #{tshowAvsFullCardNo (getFullCardNo c)} + + #{boolSymbol avsDataValid} + + _{avsDataCardColor} + + $forall a <- avsDataCardAreas + #{a} # + $if hasIssueDate + + $maybe d <- avsDataIssueDate + ^{formatTimeW SelFormatDate d} + $if hasValidToDate + + $maybe d <- avsDataValidTo + ^{formatTimeW SelFormatDate d} + $if hasCompany + + $maybe f <- avsDataFirm + #{f} + + $maybe f <- avsDataFirm + $if (primName == stripCI f) + current primary company + $else + $maybe cid <- compDict f + switch company to #{tshow cid} + |] diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 4cebd0026..912e614ac 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -3,6 +3,7 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeApplications #-} module Handler.Users ( module Handler.Users @@ -25,8 +26,13 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Database.Esqueleto.Legacy as E +-- import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E + + import Handler.Profile (makeProfileData) import qualified Yesod.Auth.Util.PasswordStore as PWStore @@ -80,7 +86,7 @@ isActionSupervisor UserSetSupervisorData{} = True isActionSupervisor _ = False -data AllUsersAction = AllUsersLdapSync +data AllUsersAction = AllUsersLdapSync | AllUsersAvsSync deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -373,7 +379,7 @@ postUsersR = do queueAvsUpdateByUID userSet Nothing addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet redirectKeepGetParams UsersR - (UserHijack, Set.minView -> Just (uid, _)) -> + (UserHijack, Set.lookupMin -> Just uid) -> hijackUser uid >>= sendResponse (UserRemoveSupervisorData, userSet) -> do runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] @@ -405,6 +411,20 @@ postUsersR = do runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) addMessageI Success MsgSynchroniseLdapAllUsersQueued redirect UsersR + AllUsersAvsSync -> do + nowaday <- liftIO getCurrentTime <&> utctDay + n <- runDB $ Ex.insertSelectCount $ do + usr <- Ex.from $ Ex.table @User + return (AvsSync + Ex.<# (usr Ex.^. UserId) + Ex.<&> E.now_ + -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock + Ex.<&> E.justVal nowaday + ) + queueJob' JobSynchroniseAvsQueue + addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n + redirect UsersR + let allUsersWgt' = wrapForm allUsersWgt def { formSubmit = FormNoSubmit , formAction = Just $ SomeRoute UsersR diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index ebfea411b..da14c9f0c 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -23,6 +23,7 @@ module Handler.Utils.Avs , retrieveDifferingLicences, retrieveDifferingLicencesStatus , computeDifferingLicences -- , synchAvsLicences + , queryAvsFullStatus -- , lookupAvsUser, lookupAvsUsers , AvsException(..) , updateReceivers @@ -136,28 +137,35 @@ catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHan -- AVS Handlers -- ------------------ +-- convenience wrapper for easy replacement with true status query +queryAvsFullStatus :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => AvsPersonId -> m AvsResponseStatus +queryAvsFullStatus api = + lookupAvsUser api <&> \case + Just AvsDataPerson{avsPersonPersonCards=cards} + | notNull cards -> AvsResponseStatus $ Set.singleton $ AvsStatusPerson api cards + _otherwise -> AvsResponseStatus mempty --- TODO: delete 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) +-- TODO: delete deprecated Utility Functions from Utils.Avs as well -- still needed, since avsStatusQuery does not deliver company names tied to cards +lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => + AvsPersonId -> m (Maybe AvsDataPerson) +lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) --- -- | retrieves complete avs user records for given AvsPersonIds. --- -- Note that this requires several AVS-API queries, since --- -- - avsQueryPerson does not support querying an AvsPersonId directly --- -- - avsQueryStatus only provides limited information --- -- avsQuery is used to obtain all card numbers, which are then queried separately an merged --- -- May throw Servant.ClientError or AvsExceptions --- -- Does not write to our own DB! --- lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => --- Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson) --- lookupAvsUsers apis = do --- AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis --- let forFoldlM = $(permuteFun [3,2,1]) foldlM --- forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> --- forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do --- AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo} --- return $ mergeByPersonId adps acc2 +-- | retrieves complete avs user records for given AvsPersonIds. +-- Note that this requires several AVS-API queries, since +-- - avsQueryPerson does not support querying an AvsPersonId directly +-- - avsQueryStatus only provides limited information +-- avsQuery is used to obtain all card numbers, which are then queried separately an merged +-- May throw Servant.ClientError or AvsExceptions +-- Does not write to our own DB! +lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => + Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson) +lookupAvsUsers apis = do + AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis + let forFoldlM = $(permuteFun [3,2,1]) foldlM + forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> + forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do + AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo} + return $ mergeByPersonId adps acc2 -- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 22266d648..686dc8692 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -76,6 +76,7 @@ abbrvName User{userDisplayName, userFirstName, userSurname} = assemble = Text.intercalate "." +-- Note: Entity can be recovered, since CompanyShort is also the key getUserPrimaryCompany :: UserId -> DB (Maybe UserCompany) getUserPrimaryCompany uid = entityVal <<$>> selectFirst [UserCompanyUser ==. uid] diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index c1048e1e7..0b0145ef0 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -447,6 +447,9 @@ deriveJSON defaultOptions , rejectUnknownFields = False } ''AvsStatusPerson +makeLenses_ ''AvsStatusPerson + + data AvsDataPerson = AvsDataPerson { avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces , avsPersonLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index aa415efff..a9c81a7c4 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 @@ -200,34 +200,34 @@ splitQuery rawQuery q -- 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 From 21273e361aa6f9722650eb6871c7bb8aa88a68dc Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 3 May 2024 17:17:24 +0200 Subject: [PATCH 3/9] chore(avs): fix #76 allowing admins to switch to secondary company --- .../uniworx/categories/avs/de-de-formal.msg | 4 +- messages/uniworx/categories/avs/en-eu.msg | 4 +- .../uniworx/categories/user/de-de-formal.msg | 1 + messages/uniworx/categories/user/en-eu.msg | 1 + routes | 2 +- src/Handler/Admin/Avs.hs | 199 +++++++++++------- src/Utils.hs | 2 +- src/Utils/Avs.hs | 51 +++-- 8 files changed, 169 insertions(+), 95 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 801c49e55..316f053dc 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -55,4 +55,6 @@ AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason} AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2} -AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt. \ No newline at end of file +AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt. +AvsCardsEmpty: AVS Suche lieferte keinerlei Ausweiskarten +AvsCurrentData: Diese angezeigten Daten wurden kürzlich über die AVS Schnittstelle abgerufen. \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index f942bd92f..6ce16160f 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -55,4 +55,6 @@ AvsPersonSearchEmpty: AVS search returned empty result AvsPersonSearchAmbiguous: AVS search returned more than one result AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason} AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead -AvsUserCreationFailed api@AvsPersonId: No new user could be created for AVS Id #{tshow api}, since an existing user shares at least one id presumed as unique \ No newline at end of file +AvsUserCreationFailed api@AvsPersonId: No new user could be created for AVS Id #{tshow api}, since an existing user shares at least one id presumed as unique +AvsCardsEmpty: AVS search returned no id cards +AvsCurrentData: This data has been recently received via the AVS interface. \ No newline at end of file diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index a5447bd65..1f6900a20 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -96,6 +96,7 @@ UserSetSupervisor: Ansprechpartner ersetzen UserRemoveSupervisor: Alle Ansprechpartner entfernen UserIsSupervisor: Ist Ansprechpartner UserAvsSwitchCompany: Als Primärfirma verwenden +UserAvsCompanySwitched c@CompanyName: Primärfirma gewechselt zu #{tshow c} AllUsersLdapSync: Alle LDAP-Synchronisieren AllUsersAvsSync: Alle AVS-Synchronisieren AuthKindLDAP: Fraport AG Kennung diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index dbad43215..fd5cde532 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -96,6 +96,7 @@ UserSetSupervisor: Replace supervisors UserRemoveSupervisor: Set to unsupervised UserIsSupervisor: Is supervisor UserAvsSwitchCompany: Use as primary company +UserAvsCompanySwitched c: Primary company switched to #{tshow c} AllUsersLdapSync: Synchronise all with LDAP AllUsersAvsSync: Synchronise all with AVS AuthKindLDAP: Fraport AG account diff --git a/routes b/routes index b3871ef8c..0585153a1 100644 --- a/routes +++ b/routes @@ -68,7 +68,7 @@ /admin/crontab AdminCrontabR GET /admin/crontab/jobs AdminJobsR GET POST /admin/avs AdminAvsR GET POST -/admin/avs/#CryptoUUIDUser AdminAvsUserR GET +/admin/avs/#CryptoUUIDUser AdminAvsUserR GET POST /admin/ldap AdminLdapR GET POST /admin/problems AdminProblemsR GET POST /admin/problems/no-contact ProblemUnreachableR GET diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 0cb2fa130..b04ea3795 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -9,7 +9,7 @@ module Handler.Admin.Avs ( getAdminAvsR, postAdminAvsR - , getAdminAvsUserR + , getAdminAvsUserR, postAdminAvsUserR , getProblemAvsSynchR, postProblemAvsSynchR , getProblemAvsErrorR ) where @@ -28,6 +28,7 @@ import Handler.Utils import Handler.Utils.Avs -- import Handler.Utils.Qualification import Handler.Utils.Users (getUserPrimaryCompany) +import Handler.Utils.Company (switchAvsUserCompany) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as E @@ -682,28 +683,67 @@ data UserAvsAction = UserAvsSwitchCompany nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAvsAction id +instance Button UniWorX UserAvsAction where + btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault] -data UserAvsActionData = UserAvsSwitchCompanyData { getAvsUser :: UserId, getAvsCompany :: CompanyId } + +data UserAvsActionData = UserAvsSwitchCompanyData { uaaUser :: CryptoUUIDUser, uaaCompany :: CompanyId } deriving (Eq, Ord, Read, Show, Generic) +-- derivePathPiece ''UserAvsActionData (camelToPathPiece' 1) "--" +-- instance Button UniWorX UserAvsActionData where +-- btnLabel UserAvsSwitchCompanyData{uaaCompany=cmp} = [whamlet|_{MsgUserAvsSwitchCompany} #{tshow cmp}|] -getAdminAvsUserR :: CryptoUUIDUser -> Handler Html -getAdminAvsUserR uuid = do +switchCompanyForm :: CryptoUUIDUser -> CompanyId -> Form UserAvsActionData +switchCompanyForm uuid cid html = flip (renderAForm FormStandard) html $ UserAvsSwitchCompanyData + <$> apopt hiddenField "" (Just uuid) + <*> apopt hiddenField "" (Just cid) + <* aopt (buttonField UserAvsSwitchCompany) "" Nothing + + +getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html +getAdminAvsUserR = postAdminAvsUserR +postAdminAvsUserR uuid = do + isModal <- hasCustomHeader HeaderIsModal + uid <- decrypt uuid Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid -- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID)) - -- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID)) + fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID)) mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId - -- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId - mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses + mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId + -- mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses + let compsUsed :: [CI Text] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just - compDict <- runDB $ do - mbPrimeComp <- getUserPrimaryCompany uid - let (primeName, fltrPrimary) = maybeEmpty mbPrimeComp $ \Company{companyName=pName, companyShorthand=pShort} -> (pName, [CompanyShorthand !=. pShort]) - compsUsed :: [Text] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just - fltrCmps = (CompanyName <-. compsUsed) : fltrPrimary - comps <- selectList fltrCmps [Asc CompanyName] -- company name is unique - return (primeName, Map.fromAscList [(cname,cid) | (Entity{entityKey=cid, entityVal=Company{companyName=cname}}) <- comps]) + runSwitchFrom :: CompanyName -> CompanyId -> Handler Widget + runSwitchFrom cname cid = do + ((fres, fraw), fenc) <- runFormPost $ switchCompanyForm uuid cid + -- formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () + formResultModal fres (AdminAvsUserR uuid) (\UserAvsSwitchCompanyData{..} -> do + problems <- lift . runDB $ do + (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany + update uid usrUp + mapM_ reportAdminProblem problems + return problems + -- todo tell all problems as well + forM_ problems (\p -> tell . pure =<< messageI Error (text2message $ tshow p)) -- todo: better display of errors + let ok = if null problems then Success else Error + tell . pure =<< messageI ok (MsgUserAvsCompanySwitched cname) + ) + let fwgt = wrapForm fraw def{ formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = fenc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} + return fwgt + + compDict <- if 1 >= length compsUsed + then return mempty -- switch company only sensible if there is more than one company to choose + else do + (primName, compDict) <- runDB $ do + mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid + mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp + let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort]) + comps :: [Entity Company] <- selectList fltrCmps [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace + return (companyName <$> mbPrimeComp, Map.fromAscList [(cname,cid) | (Entity{entityKey=cid, entityVal=Company{companyName=cname}}) <- comps]) + formDict <- Map.traverseWithKey runSwitchFrom compDict + return (primName, formDict) msgWarningTooltip <- messageI Warning MsgMessageWarning let warnBolt = messageTooltip msgWarningTooltip @@ -712,24 +752,27 @@ getAdminAvsUserR uuid = do setTitle $ toHtml $ show userAvsNoPerson let contactWgt = case mbContact of Left err -> exceptionWgt err - Right (AvsResponseContact adcs) -> do - let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs - mconcat cs + Right (AvsResponseContact adcs) -> + if null adcs + then [whamlet|_{MsgAvsPersonSearchEmpty}|] + else + let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs + in mconcat cs cardsWgt = case mbStatus of Left err -> exceptionWgt err - Right (AvsResponseStatus asts) -> do - let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts - mconcat cs - -- cardsWgt = case mbDataPerson of - -- Nothing -> mempty - -- Just AvsDataPerson{avsPersonPersonCards=crds} -> mkCardsWgt crds + Right (AvsResponseStatus asts) -> + if null asts + then [whamlet|This should not occur|] -- TODO + else + let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts + in mconcat cs [whamlet| -

- Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten:

^{contactWgt}

^{cardsWgt} +

+ _{MsgAvsCurrentData} |] where mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget @@ -775,58 +818,64 @@ getAdminAvsUserR uuid = do _{MsgAvsNoLicenceGuest} |] - mkCardsWgt :: (Maybe CompanyName, Map CompanyName CompanyId) -> Set AvsDataPersonCard -> Widget - mkCardsWgt (primName, compDict) crds = do - let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does - hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds - hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds - [whamlet| - - - - $forall c <- crds - $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c - -
_{MsgAvsCardNo} - _{MsgTableAvsCardValid} - _{MsgAvsCardColor} - _{MsgAvsCardAreas} - $if hasIssueDate - _{MsgTableAvsCardIssueDate} - $if hasValidToDate - _{MsgTableAvsCardValidTo} - $if hasCompany - _{MsgTableCompany} - -
- #{tshowAvsFullCardNo (getFullCardNo c)} - - #{boolSymbol avsDataValid} - - _{avsDataCardColor} - - $forall a <- avsDataCardAreas - #{a} # + mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget) -> Set AvsDataPersonCard -> Widget + mkCardsWgt (mbPrimName, compDict) crds + | null crds = [whamlet|_{MsgAvsCardsEmpty}|] + | otherwise = do + let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does + hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds + hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds + [whamlet| +
+ + + + + $forall c <- Set.toDescList crds + $with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c + +
_{MsgAvsCardNo} + _{MsgTableAvsCardValid} + _{MsgAvsCardColor} + _{MsgAvsCardAreas} $if hasIssueDate - - $maybe d <- avsDataIssueDate - ^{formatTimeW SelFormatDate d} - $if hasValidToDate - - $maybe d <- avsDataValidTo - ^{formatTimeW SelFormatDate d} + _{MsgTableAvsCardIssueDate} + $if hasValidToDate + _{MsgTableAvsCardValidTo} $if hasCompany - - $maybe f <- avsDataFirm - #{f} - - $maybe f <- avsDataFirm - $if (primName == stripCI f) - current primary company - $else - $maybe cid <- compDict f - switch company to #{tshow cid} - |] + _{MsgTableCompany} + _{MsgAvsPrimaryCompany} +
+ #{tshowAvsFullCardNo (getFullCardNo c)} + + #{boolSymbol avsDataValid} + + _{avsDataCardColor} + + $forall a <- avsDataCardAreas + #{a} # + $if hasIssueDate + + $maybe d <- avsDataIssueDate + ^{formatTimeW SelFormatDate d} + $if hasValidToDate + + $maybe d <- avsDataValidTo + ^{formatTimeW SelFormatDate d} + $if hasCompany + + $maybe f <- avsDataFirm + #{f} + + $maybe f <- avsDataFirm + $with fci <- stripCI f + $maybe primName <- mbPrimName + $if (primName == fci) + _{MsgAvsPrimaryCompany} + $else + $maybe wgt <- Map.lookup fci compDict + ^{wgt} + |] diff --git a/src/Utils.hs b/src/Utils.hs index 8cdad90a8..21685f564 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -922,7 +922,6 @@ deepAlt altFst _ = altFst maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty = flip foldMap - -- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a` filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a filterMaybe c r@(Just x) | c x = r @@ -950,6 +949,7 @@ positiveSum = maybePositive . getSum maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM dft act mb = mb >>= maybe dft act +-- maybeEmptyM, maybeNotingM traverseJoin :: (Applicative m, Traversable maybe, Monad maybe) => (a -> m (maybe b)) -> maybe a -> m (maybe b) traverseJoin f x = join <$> (f `traverse` x) diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index a9c81a7c4..c54b80864 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -76,25 +76,44 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery #ifdef DEVELOPMENT mkAvsQuery _ _ _ = AvsQuery - { avsQueryPerson = - let - sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty - stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty - steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty - - in \case - AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson steffen - AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> return . Right $ AvsResponsePerson steffen - AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson stephan - AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> return . Right $ AvsResponsePerson sarah - AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> return . Right $ AvsResponsePerson $ steffen <> sarah - AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson $ steffen <> stephan - _ -> return . Right $ AvsResponsePerson mempty - , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty - , avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing Nothing) + { avsQueryPerson = return . Right . fakePerson + , avsQueryStatus = return . Right . fakeStatus + , avsQueryContact = return . Right . fakeContact , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty } + where + fakePerson :: AvsQueryPerson -> AvsResponsePerson + fakePerson = + let + sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty + stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty + steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty + sumpfi1 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty + sumpfi2 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604387) mempty + sumpfi3 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604591) mempty + in \case + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson steffen + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> AvsResponsePerson steffen + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson stephan + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> AvsResponsePerson sarah + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> AvsResponsePerson $ steffen <> sarah + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ steffen <> stephan + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00006666"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3 + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00007777"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3 + AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00008888"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3 + _ -> AvsResponsePerson mempty + + fakeStatus :: AvsQueryStatus -> AvsResponseStatus + fakeStatus (AvsQueryStatus (Set.toList -> (api:_))) = AvsResponseStatus $ Set.singleton $ AvsStatusPerson api $ Set.fromList + [ AvsDataPersonCard True (Just $ fromGregorian 2026 5 1) Nothing AvsCardColorGelb (Set.fromList ['F','R','C']) Nothing Nothing Nothing (Just "Fraport AG") (AvsCardNo "6666") "4" + , AvsDataPersonCard False (Just $ fromGregorian 2025 6 2) Nothing AvsCardColorRot (Set.fromList ['F','A' ]) Nothing Nothing Nothing (Just "N*ICE Aircraft Services & Support GmbH") (AvsCardNo "7777") "4" + , AvsDataPersonCard True (Just $ fromGregorian 2028 7 3) Nothing AvsCardColorBlau mempty Nothing Nothing Nothing (Just "Fraport Facility Services GmbH") (AvsCardNo "8888") "4" + ] + fakeStatus _ = AvsResponseStatus mempty + fakeContact :: AvsQueryContact -> AvsResponseContact + fakeContact (AvsQueryContact (Set.toList -> ((AvsObjPersonId api):_))) = AvsResponseContact $ Set.singleton $ AvsDataContact api (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing) + fakeContact _ = AvsResponseContact mempty #else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery { avsQueryPerson = \q -> if q == def then return $ Right $ AvsResponsePerson mempty else -- prevent empty queries From 2fbd28154cd7aea282eaa2604a42263ac90e3b1e Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 6 May 2024 09:42:17 +0200 Subject: [PATCH 4/9] fix(build): workaround non modal form result handler --- src/Handler/Admin/Avs.hs | 35 ++++++++++++++++++++++++----------- 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index b04ea3795..953c08d5a 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -719,17 +719,30 @@ postAdminAvsUserR uuid = do runSwitchFrom cname cid = do ((fres, fraw), fenc) <- runFormPost $ switchCompanyForm uuid cid -- formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () - formResultModal fres (AdminAvsUserR uuid) (\UserAvsSwitchCompanyData{..} -> do - problems <- lift . runDB $ do - (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany - update uid usrUp - mapM_ reportAdminProblem problems - return problems - -- todo tell all problems as well - forM_ problems (\p -> tell . pure =<< messageI Error (text2message $ tshow p)) -- todo: better display of errors - let ok = if null problems then Success else Error - tell . pure =<< messageI ok (MsgUserAvsCompanySwitched cname) - ) + -- formResultModal fres (AdminAvsUserR uuid) (\UserAvsSwitchCompanyData{..} -> do + -- problems <- lift . runDB $ do + -- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany + -- update uid usrUp + -- mapM_ reportAdminProblem problems + -- return problems + -- -- todo tell all problems as well + -- forM_ problems (\p -> tell . pure =<< messageI Error (text2message $ tshow p)) -- todo: better display of errors + -- let ok = if null problems then Success else Error + -- tell . pure =<< messageI ok (MsgUserAvsCompanySwitched cname) + -- ) + let procRes (UserAvsSwitchCompanyData{..}) = do + $logInfoS "AVS" ("Switch company result " <> tshow fres) + problems <- runDB $ do + (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany + update uid usrUp + mapM_ reportAdminProblem problems + return problems + forM_ problems (\p -> do + $logErrorS "AVS" $ "Switch company problem: " <> tshow p + addMessage Error (text2Html $ tshow p)) -- todo: better display of errors + let ok = if null problems then Success else Error + addMessageI ok (MsgUserAvsCompanySwitched cname) + formResult fres procRes let fwgt = wrapForm fraw def{ formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = fenc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} return fwgt From e2e5cc7beedc8f9bf3dc9ae6f2f316a8c38be6bd Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 6 May 2024 16:33:42 +0200 Subject: [PATCH 5/9] chore(font): switch latex to roboto (WIP) --- nix/docker/default.nix | 3 ++- shell.nix | 3 ++- templates/letter/din5008.latex | 6 ++++-- templates/letter/din5008with_pin.latex | 6 ++++-- templates/letter/plain_article.latex | 8 +++++--- 5 files changed, 17 insertions(+), 9 deletions(-) diff --git a/nix/docker/default.nix b/nix/docker/default.nix index 98ec639da..1f63f37f7 100644 --- a/nix/docker/default.nix +++ b/nix/docker/default.nix @@ -31,11 +31,12 @@ let busybox # should provide a working lpr -- to be tested htop pdftk # for encrypting pdfs + roboto roboto-mono #texlive.combined.scheme-medium # too large for container in LMU build environment. (texlive.combine { inherit (texlive) scheme-basic babel-german babel-english booktabs textpos - enumitem eurosym koma-script parskip xcolor dejavu + enumitem eurosym koma-script parskip xcolor roboto # required fro LuaTeX luatexbase lualatex-math unicode-math selnolig ; diff --git a/shell.nix b/shell.nix index 42c65ae1f..d11179020 100644 --- a/shell.nix +++ b/shell.nix @@ -279,13 +279,14 @@ in pkgs.mkShell { # busybox # for print services, but interferes with build commands in develop-shell htop pdftk # pdftk just for testing pdf-passwords + roboto roboto-mono # texlive.combined.scheme-full # works # texlive.combined.scheme-medium # texlive.combined.scheme-small (texlive.combine { inherit (texlive) scheme-basic babel-german babel-english booktabs textpos - enumitem eurosym koma-script parskip xcolor dejavu + enumitem eurosym koma-script parskip xcolor roboto luatexbase lualatex-math unicode-math selnolig # required for LuaTeX ; }) diff --git a/templates/letter/din5008.latex b/templates/letter/din5008.latex index 17042126a..744b76d91 100644 --- a/templates/letter/din5008.latex +++ b/templates/letter/din5008.latex @@ -59,6 +59,8 @@ $endfor$ \def\languageshorthands#1{} $endif$ +\usepackage[sfdefault]{roboto} + \ifLuaTeX \usepackage{selnolig} % disable illegal ligatures \fi @@ -67,11 +69,11 @@ $endif$ \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp} % provide euro and other symbols - \usepackage{DejaVuSansMono} % better monofont + % \usepackage{DejaVuSansMono} % better monofont \else % if luatex or xetex \usepackage{fontspec} - \setmonofont{DejaVu Sans Mono} + % \setmonofont{DejaVu Sans Mono} \fi \renewcommand{\familydefault}{\sfdefault} diff --git a/templates/letter/din5008with_pin.latex b/templates/letter/din5008with_pin.latex index fe950b11c..3401230d7 100644 --- a/templates/letter/din5008with_pin.latex +++ b/templates/letter/din5008with_pin.latex @@ -63,15 +63,17 @@ $endif$ \usepackage{selnolig} % disable illegal ligatures \fi +\usepackage[sfdefault]{roboto} + \ifPDFTeX \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp} % provide euro and other symbols - \usepackage{DejaVuSansMono} % better monofont + % \usepackage{DejaVuSansMono} % better monofont \else % if luatex or xetex \usepackage{fontspec} - \setmonofont{DejaVu Sans Mono} + % \setmonofont{DejaVu Sans Mono} \fi \renewcommand{\familydefault}{\sfdefault} diff --git a/templates/letter/plain_article.latex b/templates/letter/plain_article.latex index 7c4038158..4ba5a5540 100644 --- a/templates/letter/plain_article.latex +++ b/templates/letter/plain_article.latex @@ -56,19 +56,21 @@ $endif$ \usepackage{selnolig} % disable illegal ligatures \fi +\usepackage[sfdefault]{roboto} + \ifPDFTeX \usepackage{helvet} \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[utf8]{inputenc} \usepackage{textcomp}% provide euro and other symbols - \usepackage{DejaVuSansMono}% better monofont + % \usepackage{DejaVuSansMono}% better monofont \renewcommand{\familydefault}{\sfdefault} \else % if luatex or xetex \usepackage{fontspec} %\setmainfont{TeXGyreHeros}%could not install the package somehow tex-gyre in default.nix/shell.nix did not work - \setmainfont{DejaVu Sans} - \setmonofont{DejaVu Sans Mono} + % \setmainfont{DejaVu Sans} + %\setmonofont{DejaVu Sans Mono} \renewcommand{\familydefault}{\sfdefault} \fi From 6084f92ad7f6f62188cb0a1b319629b9c89469c0 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 6 May 2024 16:33:57 +0200 Subject: [PATCH 6/9] chore(avs): switch prime company --- src/Handler/Admin/Avs.hs | 96 +++++++++++++++++++++++---------------- src/Handler/Admin/Test.hs | 2 +- 2 files changed, 58 insertions(+), 40 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 953c08d5a..fa1ca7837 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -28,7 +28,7 @@ import Handler.Utils import Handler.Utils.Avs -- import Handler.Utils.Qualification import Handler.Utils.Users (getUserPrimaryCompany) -import Handler.Utils.Company (switchAvsUserCompany) +-- import Handler.Utils.Company (switchAvsUserCompany) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as E @@ -715,48 +715,66 @@ postAdminAvsUserR uuid = do -- mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses let compsUsed :: [CI Text] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just - runSwitchFrom :: CompanyName -> CompanyId -> Handler Widget - runSwitchFrom cname cid = do - ((fres, fraw), fenc) <- runFormPost $ switchCompanyForm uuid cid - -- formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () - -- formResultModal fres (AdminAvsUserR uuid) (\UserAvsSwitchCompanyData{..} -> do - -- problems <- lift . runDB $ do - -- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany - -- update uid usrUp - -- mapM_ reportAdminProblem problems - -- return problems - -- -- todo tell all problems as well - -- forM_ problems (\p -> tell . pure =<< messageI Error (text2message $ tshow p)) -- todo: better display of errors - -- let ok = if null problems then Success else Error - -- tell . pure =<< messageI ok (MsgUserAvsCompanySwitched cname) - -- ) - let procRes (UserAvsSwitchCompanyData{..}) = do - $logInfoS "AVS" ("Switch company result " <> tshow fres) - problems <- runDB $ do - (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany - update uid usrUp - mapM_ reportAdminProblem problems - return problems - forM_ problems (\p -> do - $logErrorS "AVS" $ "Switch company problem: " <> tshow p - addMessage Error (text2Html $ tshow p)) -- todo: better display of errors - let ok = if null problems then Success else Error - addMessageI ok (MsgUserAvsCompanySwitched cname) - formResult fres procRes - let fwgt = wrapForm fraw def{ formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = fenc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} - return fwgt + -- runSwitchFrom :: CompanyName -> CompanyId -> Handler Widget + -- runSwitchFrom cname cid = do + -- ((fres, fraw), fenc) <- runFormPost $ switchCompanyForm uuid cid + -- -- formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () + -- -- formResultModal fres (AdminAvsUserR uuid) (\UserAvsSwitchCompanyData{..} -> do + -- -- problems <- lift . runDB $ do + -- -- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany + -- -- update uid usrUp + -- -- mapM_ reportAdminProblem problems + -- -- return problems + -- -- -- todo tell all problems as well + -- -- forM_ problems (\p -> tell . pure =<< messageI Error (text2message $ tshow p)) -- todo: better display of errors + -- -- let ok = if null problems then Success else Error + -- -- tell . pure =<< messageI ok (MsgUserAvsCompanySwitched cname) + -- -- ) + -- let procRes (UserAvsSwitchCompanyData{..}) = do + -- $logInfoS "AVS" ("Switch company result " <> tshow fres) + -- problems <- runDB $ do + -- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany + -- update uid usrUp + -- mapM_ reportAdminProblem problems + -- return problems + -- forM_ problems (\p -> do + -- $logErrorS "AVS" $ "Switch company problem: " <> tshow p + -- addMessage Error (text2Html $ tshow p)) -- todo: better display of errors + -- let ok = if null problems then Success else Error + -- addMessageI ok (MsgUserAvsCompanySwitched cname) + -- formResult fres procRes + -- let fwgt = wrapForm fraw def{ formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = fenc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} + -- return fwgt + + -- TODO: make it optional, if there are eligible companies only + switchCompForm :: Handler Widget + switchCompForm = do + let switchAllCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyName) + switchAllCompForm = (,) + <$> areq hiddenField "user-id" (Just uuid) + <*> areq (selectFieldList [(ciOriginal c, c) | c <- compsUsed]) "new primary company" Nothing + <* aopt (buttonField UserAvsSwitchCompany) "" Nothing + ((spRes, spWgt), spEnc) <- runFormPost . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchAllCompForm + formResultModal spRes (AdminAvsUserR uuid) (\(_,c) -> do + lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes) + tell . pure $ Message Success [shamlet|TODO #{c} received|] Nothing + ) + return $ wrapForm spWgt + def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} compDict <- if 1 >= length compsUsed then return mempty -- switch company only sensible if there is more than one company to choose else do - (primName, compDict) <- runDB $ do + (primName, _compDict) <- runDB $ do mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort]) comps :: [Entity Company] <- selectList fltrCmps [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace return (companyName <$> mbPrimeComp, Map.fromAscList [(cname,cid) | (Entity{entityKey=cid, entityVal=Company{companyName=cname}}) <- comps]) - formDict <- Map.traverseWithKey runSwitchFrom compDict - return (primName, formDict) + -- formDict <- Map.traverseWithKey runSwitchFrom compDict + swForm <- switchCompForm + return (primName, --formDict, + swForm) msgWarningTooltip <- messageI Warning MsgMessageWarning let warnBolt = messageTooltip msgWarningTooltip @@ -831,8 +849,9 @@ postAdminAvsUserR uuid = do _{MsgAvsNoLicenceGuest} |] - mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget) -> Set AvsDataPersonCard -> Widget - mkCardsWgt (mbPrimName, compDict) crds + -- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget + mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget + mkCardsWgt (mbPrimName, swForm) crds | null crds = [whamlet|_{MsgAvsCardsEmpty}|] | otherwise = do let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does @@ -885,9 +904,8 @@ postAdminAvsUserR uuid = do $maybe primName <- mbPrimName $if (primName == fci) _{MsgAvsPrimaryCompany} - $else - $maybe wgt <- Map.lookup fci compDict - ^{wgt} +

+ ^{swForm} |] diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 50b670d2e..dc235ac3f 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -112,7 +112,7 @@ postAdminTestR = do let emailWidget' = wrapForm emailWidget def { formAction = Just . SomeRoute $ AdminTestR , formEncoding = emailEnctype - , formAttrs = [("uw-async-form", "")] + , formAttrs = [asyncSubmitAttr] -- equivalent to [("uw-async-form", "")] } now <- liftIO getCurrentTime From 29182cb6dd33dab1d85f655b51978960d8a85d69 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 6 May 2024 16:58:58 +0200 Subject: [PATCH 7/9] chore(avs): switch company (WIP) --- src/Handler/Admin/Avs.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index fa1ca7837..5ac754d06 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -747,20 +747,20 @@ postAdminAvsUserR uuid = do -- return fwgt -- TODO: make it optional, if there are eligible companies only - switchCompForm :: Handler Widget - switchCompForm = do + switchCompForm :: Maybe Company -> Handler Widget + switchCompForm mbPrime = do let switchAllCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyName) switchAllCompForm = (,) <$> areq hiddenField "user-id" (Just uuid) - <*> areq (selectFieldList [(ciOriginal c, c) | c <- compsUsed]) "new primary company" Nothing - <* aopt (buttonField UserAvsSwitchCompany) "" Nothing + <*> areq (selectFieldList [(ciOriginal c, c) | c <- compsUsed]) "new primary company" (companyName <$> mbPrime) + -- <* aopt (buttonField UserAvsSwitchCompany) "" Nothing ((spRes, spWgt), spEnc) <- runFormPost . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchAllCompForm formResultModal spRes (AdminAvsUserR uuid) (\(_,c) -> do lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes) tell . pure $ Message Success [shamlet|TODO #{c} received|] Nothing ) return $ wrapForm spWgt - def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} + def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} compDict <- if 1 >= length compsUsed then return mempty -- switch company only sensible if there is more than one company to choose @@ -772,7 +772,7 @@ postAdminAvsUserR uuid = do comps :: [Entity Company] <- selectList fltrCmps [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace return (companyName <$> mbPrimeComp, Map.fromAscList [(cname,cid) | (Entity{entityKey=cid, entityVal=Company{companyName=cname}}) <- comps]) -- formDict <- Map.traverseWithKey runSwitchFrom compDict - swForm <- switchCompForm + swForm <- switchCompForm mbPrimeComp return (primName, --formDict, swForm) From 3c4a0b86c1e3d8a28405ab73b964ba1b988d2822 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 6 May 2024 19:35:59 +0200 Subject: [PATCH 8/9] fix(avs): fix #76 allowing company changes and fix #69 --- .../uniworx/categories/user/de-de-formal.msg | 2 +- src/Handler/Admin.hs | 38 ++++-- src/Handler/Admin/Avs.hs | 108 ++++++------------ src/Handler/Utils.hs | 31 ++++- src/Handler/Utils/Company.hs | 6 +- 5 files changed, 99 insertions(+), 86 deletions(-) diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 1f6900a20..f2471f4dc 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -96,7 +96,7 @@ UserSetSupervisor: Ansprechpartner ersetzen UserRemoveSupervisor: Alle Ansprechpartner entfernen UserIsSupervisor: Ist Ansprechpartner UserAvsSwitchCompany: Als Primärfirma verwenden -UserAvsCompanySwitched c@CompanyName: Primärfirma gewechselt zu #{tshow c} +UserAvsCompanySwitched c@CompanyShorthand: Primärfirma gewechselt zu #{tshow c} AllUsersLdapSync: Alle LDAP-Synchronisieren AllUsersAvsSync: Alle AVS-Synchronisieren AuthKindLDAP: Fraport AG Kennung diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index ae4dd7aa4..53c5d6116 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -26,6 +26,7 @@ import qualified Database.Esqueleto.Utils as E import Handler.Utils import Handler.Utils.Avs import Handler.Utils.Users +-- import Handler.Utils.Company import Handler.Health.Interface import Handler.Admin.Test as Handler.Admin @@ -374,15 +375,28 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..} let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) -adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a --- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns -adminProblemCell AdminProblemNewCompany{} - = i18nCell MsgAdminProblemNewCompany -adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} - = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew -adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} - = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) -adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} - = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew -adminProblemCell AdminProblemUnknown{adminProblemText} - = textCell $ "Problem: " <> adminProblemText +-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a +-- -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns +-- adminProblemCell AdminProblemNewCompany{} +-- = i18nCell MsgAdminProblemNewCompany +-- adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} +-- = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew +-- adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} +-- = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) +-- adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} +-- = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew +-- adminProblemCell AdminProblemUnknown{adminProblemText} +-- = textCell $ "Problem: " <> adminProblemText + + +-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) +-- msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ +-- SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp] +-- msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp} = return $ +-- SomeMessages [SomeMessage MsgAdminProblemSupervisorNewCompany, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp] +-- msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp} = return $ +-- SomeMessages [SomeMessage MsgAdminProblemSupervisorLeftCompany, text2message ": ", company2msg comp] +-- msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ +-- SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp] +-- msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $ +-- someMessages ["Problem: ", err] \ No newline at end of file diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 5ac754d06..1a6bdaf19 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -28,7 +28,7 @@ import Handler.Utils import Handler.Utils.Avs -- import Handler.Utils.Qualification import Handler.Utils.Users (getUserPrimaryCompany) --- import Handler.Utils.Company (switchAvsUserCompany) +import Handler.Utils.Company (switchAvsUserCompany) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as E @@ -687,19 +687,6 @@ instance Button UniWorX UserAvsAction where btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault] -data UserAvsActionData = UserAvsSwitchCompanyData { uaaUser :: CryptoUUIDUser, uaaCompany :: CompanyId } - deriving (Eq, Ord, Read, Show, Generic) --- derivePathPiece ''UserAvsActionData (camelToPathPiece' 1) "--" --- instance Button UniWorX UserAvsActionData where --- btnLabel UserAvsSwitchCompanyData{uaaCompany=cmp} = [whamlet|_{MsgUserAvsSwitchCompany} #{tshow cmp}|] - -switchCompanyForm :: CryptoUUIDUser -> CompanyId -> Form UserAvsActionData -switchCompanyForm uuid cid html = flip (renderAForm FormStandard) html $ UserAvsSwitchCompanyData - <$> apopt hiddenField "" (Just uuid) - <*> apopt hiddenField "" (Just cid) - <* aopt (buttonField UserAvsSwitchCompany) "" Nothing - - getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html getAdminAvsUserR = postAdminAvsUserR postAdminAvsUserR uuid = do @@ -713,68 +700,47 @@ postAdminAvsUserR uuid = do mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId -- mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses - let compsUsed :: [CI Text] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just - - -- runSwitchFrom :: CompanyName -> CompanyId -> Handler Widget - -- runSwitchFrom cname cid = do - -- ((fres, fraw), fenc) <- runFormPost $ switchCompanyForm uuid cid - -- -- formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () - -- -- formResultModal fres (AdminAvsUserR uuid) (\UserAvsSwitchCompanyData{..} -> do - -- -- problems <- lift . runDB $ do - -- -- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany - -- -- update uid usrUp - -- -- mapM_ reportAdminProblem problems - -- -- return problems - -- -- -- todo tell all problems as well - -- -- forM_ problems (\p -> tell . pure =<< messageI Error (text2message $ tshow p)) -- todo: better display of errors - -- -- let ok = if null problems then Success else Error - -- -- tell . pure =<< messageI ok (MsgUserAvsCompanySwitched cname) - -- -- ) - -- let procRes (UserAvsSwitchCompanyData{..}) = do - -- $logInfoS "AVS" ("Switch company result " <> tshow fres) - -- problems <- runDB $ do - -- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany - -- update uid usrUp - -- mapM_ reportAdminProblem problems - -- return problems - -- forM_ problems (\p -> do - -- $logErrorS "AVS" $ "Switch company problem: " <> tshow p - -- addMessage Error (text2Html $ tshow p)) -- todo: better display of errors - -- let ok = if null problems then Success else Error - -- addMessageI ok (MsgUserAvsCompanySwitched cname) - -- formResult fres procRes - -- let fwgt = wrapForm fraw def{ formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = fenc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} - -- return fwgt - - -- TODO: make it optional, if there are eligible companies only - switchCompForm :: Maybe Company -> Handler Widget - switchCompForm mbPrime = do - let switchAllCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyName) - switchAllCompForm = (,) - <$> areq hiddenField "user-id" (Just uuid) - <*> areq (selectFieldList [(ciOriginal c, c) | c <- compsUsed]) "new primary company" (companyName <$> mbPrime) - -- <* aopt (buttonField UserAvsSwitchCompany) "" Nothing - ((spRes, spWgt), spEnc) <- runFormPost . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchAllCompForm - formResultModal spRes (AdminAvsUserR uuid) (\(_,c) -> do - lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes) - tell . pure $ Message Success [shamlet|TODO #{c} received|] Nothing - ) - return $ wrapForm spWgt - def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} - + let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just compDict <- if 1 >= length compsUsed then return mempty -- switch company only sensible if there is more than one company to choose - else do - (primName, _compDict) <- runDB $ do + else do + let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget + switchCompFormHandler availComps _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company + switchCompFormHandler availComps mbPrime = do + let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId) + switchCompForm = (,) + <$> apopt hiddenField "" (Just uuid) + <*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) "new primary company" mbPrime + <* aopt (buttonField UserAvsSwitchCompany) "" Nothing + switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler () + switchCompValidate = do + (uuid_rcvd,_) <- State.get + guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid + ((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm + formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do + lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes) + problems <- liftHandler . runDB $ do + (usrUp, problems) <- switchAvsUserCompany True False uid cid + update uid usrUp + forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p + forM_ problems (\p -> do + -- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages + tell . pure =<< messageI Warning p + ) + let ok = if null problems then Success else Error + tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid) + ) + return $ wrapForm spWgt + def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} + (availComps, primName, primId) <- runDB $ do mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp - let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort]) - comps :: [Entity Company] <- selectList fltrCmps [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace - return (companyName <$> mbPrimeComp, Map.fromAscList [(cname,cid) | (Entity{entityKey=cid, entityVal=Company{companyName=cname}}) <- comps]) + -- let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort]) + comps :: [Entity Company] <- selectList [CompanyName <-. compsUsed] [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace + return ([(companyName v, k) | (Entity k v) <- comps], companyName <$> mbPrimeComp, CompanyKey . companyShorthand <$> mbPrimeComp) -- formDict <- Map.traverseWithKey runSwitchFrom compDict - swForm <- switchCompForm mbPrimeComp - return (primName, --formDict, - swForm) + swForm <- switchCompFormHandler availComps primId + return (primName, swForm) msgWarningTooltip <- messageI Warning MsgMessageWarning let warnBolt = messageTooltip msgWarningTooltip diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 4648cf647..8043737de 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -161,4 +161,33 @@ reloadKeepGetParams r = liftHandler $ do redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a redirectKeepGetParams route = liftHandler $ do getps <- reqGetParams <$> getRequest - redirect (route, getps) \ No newline at end of file + redirect (route, getps) + + +adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a +-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns +adminProblemCell AdminProblemNewCompany{} + = i18nCell MsgAdminProblemNewCompany +adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} + = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew +adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute} + = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute) +adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} + = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew +adminProblemCell AdminProblemUnknown{adminProblemText} + = textCell $ "Problem: " <> adminProblemText + +company2msg :: CompanyId -> SomeMessage UniWorX +company2msg = text2message . ciOriginal . unCompanyKey + +msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) +msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $ + SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp] +msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $ + SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp] +msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $ + SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp] +msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $ + SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp] +msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $ + someMessages ["Problem: ", err] \ No newline at end of file diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index f20089255..a5d90c0cb 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -20,8 +20,12 @@ import qualified Database.Esqueleto.PostgreSQL as E import Handler.Utils.Users --- TODO: use this function in company view Handler.Firm #157 +company2msg :: CompanyId -> SomeMessage UniWorX +company2msg = text2message . ciOriginal . unCompanyKey + + +-- TODO: use this function in company view Handler.Firm #157 -- | add all company supervisors for a given users addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend) => Key Company -> Key User -> ReaderT backend m () From 6750798920dc76882f4e8ef39b47018fb7b77e44 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 6 May 2024 19:47:34 +0200 Subject: [PATCH 9/9] fix(build): add missing tex packages --- nix/docker/default.nix | 2 +- shell.nix | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/nix/docker/default.nix b/nix/docker/default.nix index 1f63f37f7..f01a9f3b0 100644 --- a/nix/docker/default.nix +++ b/nix/docker/default.nix @@ -36,7 +36,7 @@ let (texlive.combine { inherit (texlive) scheme-basic babel-german babel-english booktabs textpos - enumitem eurosym koma-script parskip xcolor roboto + enumitem eurosym koma-script parskip xcolor roboto xkeyval # required fro LuaTeX luatexbase lualatex-math unicode-math selnolig ; diff --git a/shell.nix b/shell.nix index d11179020..fada1fae8 100644 --- a/shell.nix +++ b/shell.nix @@ -286,7 +286,7 @@ in pkgs.mkShell { (texlive.combine { inherit (texlive) scheme-basic babel-german babel-english booktabs textpos - enumitem eurosym koma-script parskip xcolor roboto + enumitem eurosym koma-script parskip xcolor roboto xkeyval luatexbase lualatex-math unicode-math selnolig # required for LuaTeX ; })