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

Merge branch 'fradrive/cr3'

Browse Source
This commit is contained in:
Steffen Jost 2024-05-06 20:01:26 +02:00
commit 7fd13677d3
30 changed files with 714 additions and 432 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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

4
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -55,4 +55,6 @@ AvsPersonSearchEmpty: AVS Suche lieferte leeres Ergebnis
AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse AvsPersonSearchAmbiguous: AVS Suche lieferte mehrere uneindeutige Ergebnisse
AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason} 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} 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. 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.

4
messages/uniworx/categories/avs/en-eu.msg
View File

@ -55,4 +55,6 @@ AvsPersonSearchEmpty: AVS search returned empty result
AvsPersonSearchAmbiguous: AVS search returned more than one result AvsPersonSearchAmbiguous: AVS search returned more than one result
AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason} AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason}
AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead 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 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.

8
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -37,7 +37,8 @@ AuthPWHashAlreadyConfigured: Nutzer:in meldet sich bereits mit FRADrive spezifis
AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennung an
UsersCourseSchool: Bereich UsersCourseSchool: Bereich
ActionNoUsersSelected: Keine Benutzer:innen ausgewählt 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 SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
UserListTitle: Komprehensive Benutzerliste UserListTitle: Komprehensive Benutzerliste
@ -89,12 +90,15 @@ 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! 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 UserAvsSync: AVS-Synchronisieren
UserLdapSync: LDAP-Synchronisieren UserLdapSync: LDAP-Synchronisieren
AllUsersLdapSync: Alle LDAP-Synchronisieren
UserHijack: Sitzung übernehmen UserHijack: Sitzung übernehmen
UserAddSupervisor: Ansprechpartner hinzufügen UserAddSupervisor: Ansprechpartner hinzufügen
UserSetSupervisor: Ansprechpartner ersetzen UserSetSupervisor: Ansprechpartner ersetzen
UserRemoveSupervisor: Alle Ansprechpartner entfernen UserRemoveSupervisor: Alle Ansprechpartner entfernen
UserIsSupervisor: Ist Ansprechpartner UserIsSupervisor: Ist Ansprechpartner
UserAvsSwitchCompany: Als Primärfirma verwenden
UserAvsCompanySwitched c@CompanyShorthand: Primärfirma gewechselt zu #{tshow c}
AllUsersLdapSync: Alle LDAP-Synchronisieren
AllUsersAvsSync: Alle AVS-Synchronisieren
AuthKindLDAP: Fraport AG Kennung AuthKindLDAP: Fraport AG Kennung
AuthKindPWHash: FRADrive Kennung AuthKindPWHash: FRADrive Kennung
AuthKindNoLogin: Kein Login möglich AuthKindNoLogin: Kein Login möglich

10
messages/uniworx/categories/user/en-eu.msg
View File

@ -37,8 +37,9 @@ AuthPWHashAlreadyConfigured: User already logs in using their FRADrive specific
AuthPWHashConfigured: User now logs in using their FRADrive specific account AuthPWHashConfigured: User now logs in using their FRADrive specific account
UsersCourseSchool: Department UsersCourseSchool: Department
ActionNoUsersSelected: No users selected ActionNoUsersSelected: No users selected
SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}. SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}
SynchroniseLdapUserQueued n: Triggered LDAP 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 SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
UserListTitle: Comprehensive list of users UserListTitle: Comprehensive list of users
AccessRightsSaved: Successfully updated permissions AccessRightsSaved: Successfully updated permissions
@ -89,12 +90,15 @@ NewPasswordLink: Set password
UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term! UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term!
UserAvsSync: Synchronise with AVS UserAvsSync: Synchronise with AVS
UserLdapSync: Synchronise with LDAP UserLdapSync: Synchronise with LDAP
AllUsersLdapSync: Synchronise all with LDAP
UserHijack: Hijack session UserHijack: Hijack session
UserAddSupervisor: Add supervisor UserAddSupervisor: Add supervisor
UserSetSupervisor: Replace supervisors UserSetSupervisor: Replace supervisors
UserRemoveSupervisor: Set to unsupervised UserRemoveSupervisor: Set to unsupervised
UserIsSupervisor: Is supervisor 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 AuthKindLDAP: Fraport AG account
AuthKindPWHash: FRADrive account AuthKindPWHash: FRADrive account
AuthKindNoLogin: No login AuthKindNoLogin: No login

3
nix/docker/default.nix
View File

@ -31,11 +31,12 @@ let
busybox # should provide a working lpr -- to be tested busybox # should provide a working lpr -- to be tested
htop htop
pdftk # for encrypting pdfs pdftk # for encrypting pdfs
roboto roboto-mono
#texlive.combined.scheme-medium # too large for container in LMU build environment. #texlive.combined.scheme-medium # too large for container in LMU build environment.
(texlive.combine { (texlive.combine {
inherit (texlive) scheme-basic inherit (texlive) scheme-basic
babel-german babel-english booktabs textpos babel-german babel-english booktabs textpos
enumitem eurosym koma-script parskip xcolor dejavu enumitem eurosym koma-script parskip xcolor roboto xkeyval
# required fro LuaTeX # required fro LuaTeX
luatexbase lualatex-math unicode-math selnolig luatexbase lualatex-math unicode-math selnolig
; ;

2
routes
View File

@ -68,7 +68,7 @@
/admin/crontab AdminCrontabR GET /admin/crontab AdminCrontabR GET
/admin/crontab/jobs AdminJobsR GET POST /admin/crontab/jobs AdminJobsR GET POST
/admin/avs AdminAvsR GET POST /admin/avs AdminAvsR GET POST
/admin/avs/#CryptoUUIDUser AdminAvsUserR GET /admin/avs/#CryptoUUIDUser AdminAvsUserR GET POST
/admin/ldap AdminLdapR GET POST /admin/ldap AdminLdapR GET POST
/admin/problems AdminProblemsR GET POST /admin/problems AdminProblemsR GET POST
/admin/problems/no-contact ProblemUnreachableR GET /admin/problems/no-contact ProblemUnreachableR GET

3
shell.nix
View File

@ -279,13 +279,14 @@ in pkgs.mkShell {
# busybox # for print services, but interferes with build commands in develop-shell # busybox # for print services, but interferes with build commands in develop-shell
htop htop
pdftk # pdftk just for testing pdf-passwords pdftk # pdftk just for testing pdf-passwords
roboto roboto-mono
# texlive.combined.scheme-full # works # texlive.combined.scheme-full # works
# texlive.combined.scheme-medium # texlive.combined.scheme-medium
# texlive.combined.scheme-small # texlive.combined.scheme-small
(texlive.combine { (texlive.combine {
inherit (texlive) scheme-basic inherit (texlive) scheme-basic
babel-german babel-english booktabs textpos babel-german babel-english booktabs textpos
enumitem eurosym koma-script parskip xcolor dejavu enumitem eurosym koma-script parskip xcolor roboto xkeyval
luatexbase lualatex-math unicode-math selnolig # required for LuaTeX luatexbase lualatex-math unicode-math selnolig # required for LuaTeX
; ;
}) })

9
src/Audit/Types.hs
View File

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

36
src/Handler/Admin.hs
View File

@ -26,6 +26,7 @@ import qualified Database.Esqueleto.Utils as E
import Handler.Utils import Handler.Utils
import Handler.Utils.Avs import Handler.Utils.Avs
import Handler.Utils.Users import Handler.Utils.Users
-- import Handler.Utils.Company
import Handler.Health.Interface import Handler.Health.Interface
import Handler.Admin.Test as Handler.Admin import Handler.Admin.Test as Handler.Admin
@ -374,13 +375,28 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet) return (act, usrSet)
adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns -- -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
adminProblemCell AdminProblemNewCompany{} -- adminProblemCell AdminProblemNewCompany{}
= i18nCell MsgAdminProblemNewCompany -- = i18nCell MsgAdminProblemNewCompany
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} -- adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
= i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew -- = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew} -- adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
= i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew -- = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
adminProblemCell AdminProblemUnknown{adminProblemText} -- adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
= textCell $ "Problem: " <> adminProblemText -- = 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]

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

@ -9,7 +9,7 @@
module Handler.Admin.Avs module Handler.Admin.Avs
( getAdminAvsR, postAdminAvsR ( getAdminAvsR, postAdminAvsR
, getAdminAvsUserR , getAdminAvsUserR, postAdminAvsUserR
, getProblemAvsSynchR, postProblemAvsSynchR , getProblemAvsSynchR, postProblemAvsSynchR
, getProblemAvsErrorR , getProblemAvsErrorR
) where ) where
@ -27,7 +27,8 @@ import qualified Data.Map as Map
import Handler.Utils import Handler.Utils
import Handler.Utils.Avs import Handler.Utils.Avs
-- import Handler.Utils.Qualification -- import Handler.Utils.Qualification
import Handler.Utils.Users (getUserPrimaryCompany)
import Handler.Utils.Company (switchAvsUserCompany)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
@ -676,151 +677,202 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
getAdminAvsUserR :: CryptoUUIDUser -> Handler Html data UserAvsAction = UserAvsSwitchCompany
getAdminAvsUserR uuid = do deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
uid <- decrypt uuid deriving anyclass (Universe, Finite)
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1
mbStatus <- try $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId embedRenderMessage ''UniWorX ''UserAvsAction id
-- mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed instance Button UniWorX UserAvsAction where
btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault]
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|
<p>
Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten:
<p>
^{contactWgt}
<p>
^{cardsWgt}
|]
-- <p>
-- Vorläufige Admin Ansicht AVS Daten.
-- Ansicht zeigt aktuelle Daten.
-- Es erfolgte damit aber noch kein Update der FRADrive Daten.
-- <p>
-- <dl .deflist>
-- <dt .deflist__dt>InfoPersonContact <br>
-- <i>(bevorzugt)
-- <dd .deflist__dd>
-- $case mbContact
-- $of Left err
-- ^{exceptionWgt err}
-- $of Right contactInfo
-- #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
-- <dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
-- <i>(benötigt mehrere AVS Abfragen)
-- <dd .deflist__dd>
-- $maybe dataPerson <- mbDataPerson
-- #{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
-- $nothing
-- Keine Daten erhalten.
-- <h3>
-- Provisorische formatierte Ansicht
-- <p>
-- Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
-- In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
-- <p>
-- ^{foldMap jsonWidget mbContact}
-- <p>
-- ^{foldMap jsonWidget mbDataPerson}
-- |]
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
mkContactWgt warnBolt reqAvsNo AvsDataContact getAdminAvsUserR = postAdminAvsUserR
{ -- avsContactPersonID = _api postAdminAvsUserR uuid = do
avsContactPersonInfo = AvsPersonInfo{..} isModal <- hasCustomHeader HeaderIsModal
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
} = uid <- decrypt uuid
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
[whamlet| -- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
<section .profile> let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
<dl .deflist.profile-dl> fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
$if avsNoOk mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
<dt .deflist__dt> mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
_{MsgAvsPersonNo} -- 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
<dd .deflist__dd> let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
#{avsInfoPersonNo} compDict <- if 1 >= length compsUsed
^{warnBolt} then return mempty -- switch company only sensible if there is more than one company to choose
_{MsgAvsPersonNoMismatch} else do
<dt .deflist__dt> let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
_{MsgAvsLastName} switchCompFormHandler availComps _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company
<dd .deflist__dd> switchCompFormHandler availComps mbPrime = do
#{avsInfoLastName} let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId)
<dt .deflist__dt> switchCompForm = (,)
_{MsgAvsFirstName} <$> apopt hiddenField "" (Just uuid)
<dd .deflist__dd> <*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) "new primary company" mbPrime
#{avsInfoFirstName} <* aopt (buttonField UserAvsSwitchCompany) "" Nothing
<dt .deflist__dt> switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
_{MsgAvsPrimaryCompany} switchCompValidate = do
<dd .deflist__dd> (uuid_rcvd,_) <- State.get
#{firmName} guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
$maybe bday <- avsInfoDateOfBirth ((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
<dt .deflist__dt> formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
_{MsgAdminUserBirthday} lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
<dd .deflist__dd> problems <- liftHandler . runDB $ do
^{formatTimeW SelFormatDate bday} (usrUp, problems) <- switchAvsUserCompany True False uid cid
<dt .deflist__dt> update uid usrUp
_{MsgAvsLicence} forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
<dd .deflist__dd> forM_ problems (\p -> do
$maybe licence <- parseAvsLicence avsInfoRampLicence -- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
_{licence} tell . pure =<< messageI Warning p
$nothing )
_{MsgAvsNoLicenceGuest} 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 [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 <- switchCompFormHandler availComps primId
return (primName, swForm)
mkCardsWgt :: Set AvsDataPersonCard -> Widget msgWarningTooltip <- messageI Warning MsgMessageWarning
mkCardsWgt crds = let warnBolt = messageTooltip msgWarningTooltip
[whamlet| heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
<table> siteLayout heading $ do
<thead> setTitle $ toHtml $ show userAvsNoPerson
<th>_{MsgAvsCardNo} let contactWgt = case mbContact of
<th>_{MsgTableAvsCardValid} Left err -> exceptionWgt err
<th>_{MsgAvsCardColor} Right (AvsResponseContact adcs) ->
<th>_{MsgAvsCardAreas} if null adcs
<th>_{MsgTableCompany} then [whamlet|_{MsgAvsPersonSearchEmpty}|]
<th>_{MsgTableAvsCardIssueDate} else
<th>_{MsgTableAvsCardValidTo} let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
<tbody> in mconcat cs
$forall c <- crds cardsWgt = case mbStatus of
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c Left err -> exceptionWgt err
<tr> Right (AvsResponseStatus asts) ->
<td> if null asts
#{tshowAvsFullCardNo (getFullCardNo c)} then [whamlet|This should not occur|] -- TODO
<td> else
#{boolSymbol avsDataValid} let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
<td> in mconcat cs
_{avsDataCardColor} [whamlet|
<td> <p>
$forall a <- avsDataCardAreas ^{contactWgt}
#{a} # <p>
<td> ^{cardsWgt}
$maybe f <- avsDataFirm <p>
#{f} _{MsgAvsCurrentData}
<td> |]
$maybe d <- avsDataIssueDate where
^{formatTimeW SelFormatDate d} mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
<td> mkContactWgt warnBolt reqAvsNo AvsDataContact
$maybe d <- avsDataValidTo { -- avsContactPersonID = _api
^{formatTimeW SelFormatDate d} avsContactPersonInfo = AvsPersonInfo{..}
|] , avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
} =
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
[whamlet|
<section .profile>
<dl .deflist.profile-dl>
$if avsNoOk
<dt .deflist__dt>
_{MsgAvsPersonNo}
<dd .deflist__dd>
#{avsInfoPersonNo}
^{warnBolt}
_{MsgAvsPersonNoMismatch}
<dt .deflist__dt>
_{MsgAvsLastName}
<dd .deflist__dd>
#{avsInfoLastName}
<dt .deflist__dt>
_{MsgAvsFirstName}
<dd .deflist__dd>
#{avsInfoFirstName}
<dt .deflist__dt>
_{MsgAvsPrimaryCompany}
<dd .deflist__dd>
#{firmName}
$maybe bday <- avsInfoDateOfBirth
<dt .deflist__dt>
_{MsgAdminUserBirthday}
<dd .deflist__dd>
^{formatTimeW SelFormatDate bday}
<dt .deflist__dt>
_{MsgAvsLicence}
<dd .deflist__dd>
$maybe licence <- parseAvsLicence avsInfoRampLicence
_{licence}
$nothing
_{MsgAvsNoLicenceGuest}
|]
-- 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
hasIssueDate = isJust $ Set.foldr ((<|>) . avsDataIssueDate) Nothing crds
hasValidToDate = isJust $ Set.foldr ((<|>) . avsDataValidTo) Nothing crds
[whamlet|
<div .scrolltable .scrolltable-bordered>
<table .table .table--striped>
<thead>
<tr .table__row .table__row--head>
<th .table__th>_{MsgAvsCardNo}
<th .table__th>_{MsgTableAvsCardValid}
<th .table__th>_{MsgAvsCardColor}
<th .table__th>_{MsgAvsCardAreas}
$if hasIssueDate
<th .table__th>_{MsgTableAvsCardIssueDate}
$if hasValidToDate
<th .table__th>_{MsgTableAvsCardValidTo}
$if hasCompany
<th .table__th>_{MsgTableCompany}
<th .table__th>_{MsgAvsPrimaryCompany}
<tbody>
$forall c <- Set.toDescList crds
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
<tr .table__row>
<td .table__td>
#{tshowAvsFullCardNo (getFullCardNo c)}
<td .table__td>
#{boolSymbol avsDataValid}
<td .table__td>
_{avsDataCardColor}
<td .table__td>
$forall a <- avsDataCardAreas
#{a} #
$if hasIssueDate
<td .table__td>
$maybe d <- avsDataIssueDate
^{formatTimeW SelFormatDate d}
$if hasValidToDate
<td .table__td>
$maybe d <- avsDataValidTo
^{formatTimeW SelFormatDate d}
$if hasCompany
<td .table__td>
$maybe f <- avsDataFirm
#{f}
<td .table__td>
$maybe f <- avsDataFirm
$with fci <- stripCI f
$maybe primName <- mbPrimName
$if (primName == fci)
_{MsgAvsPrimaryCompany}
<p>
^{swForm}
|]

2
src/Handler/Admin/Test.hs
View File

@ -112,7 +112,7 @@ postAdminTestR = do
let emailWidget' = wrapForm emailWidget def let emailWidget' = wrapForm emailWidget def
{ formAction = Just . SomeRoute $ AdminTestR { formAction = Just . SomeRoute $ AdminTestR
, formEncoding = emailEnctype , formEncoding = emailEnctype
, formAttrs = [("uw-async-form", "")] , formAttrs = [asyncSubmitAttr] -- equivalent to [("uw-async-form", "")]
} }
now <- liftIO getCurrentTime now <- liftIO getCurrentTime

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

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

24
src/Handler/Users.hs
View File

@ -3,6 +3,7 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeApplications #-}
module Handler.Users module Handler.Users
( module Handler.Users ( module Handler.Users
@ -25,8 +26,13 @@ import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Database.Esqueleto.Legacy as E 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 qualified Database.Esqueleto.Utils as E
import Handler.Profile (makeProfileData) import Handler.Profile (makeProfileData)
import qualified Yesod.Auth.Util.PasswordStore as PWStore import qualified Yesod.Auth.Util.PasswordStore as PWStore
@ -80,7 +86,7 @@ isActionSupervisor UserSetSupervisorData{} = True
isActionSupervisor _ = False isActionSupervisor _ = False
data AllUsersAction = AllUsersLdapSync data AllUsersAction = AllUsersLdapSync | AllUsersAvsSync
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)
@ -373,7 +379,7 @@ postUsersR = do
queueAvsUpdateByUID userSet Nothing queueAvsUpdateByUID userSet Nothing
addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
redirectKeepGetParams UsersR redirectKeepGetParams UsersR
(UserHijack, Set.minView -> Just (uid, _)) -> (UserHijack, Set.lookupMin -> Just uid) ->
hijackUser uid >>= sendResponse hijackUser uid >>= sendResponse
(UserRemoveSupervisorData, userSet) -> do (UserRemoveSupervisorData, userSet) -> do
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
@ -405,6 +411,20 @@ postUsersR = do
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
addMessageI Success MsgSynchroniseLdapAllUsersQueued addMessageI Success MsgSynchroniseLdapAllUsersQueued
redirect UsersR 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 let allUsersWgt' = wrapForm allUsersWgt def
{ formSubmit = FormNoSubmit { formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute UsersR , formAction = Just $ SomeRoute UsersR

31
src/Handler/Utils.hs
View File

@ -161,4 +161,33 @@ reloadKeepGetParams r = liftHandler $ do
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
redirectKeepGetParams route = liftHandler $ do redirectKeepGetParams route = liftHandler $ do
getps <- reqGetParams <$> getRequest getps <- reqGetParams <$> getRequest
redirect (route, getps) 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]

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

@ -23,6 +23,7 @@ module Handler.Utils.Avs
, retrieveDifferingLicences, retrieveDifferingLicencesStatus , retrieveDifferingLicences, retrieveDifferingLicencesStatus
, computeDifferingLicences , computeDifferingLicences
-- , synchAvsLicences -- , synchAvsLicences
, queryAvsFullStatus
-- , lookupAvsUser, lookupAvsUsers -- , lookupAvsUser, lookupAvsUsers
, AvsException(..) , AvsException(..)
, updateReceivers , updateReceivers
@ -51,15 +52,12 @@ import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionExce
import Jobs.Queue import Jobs.Queue
import Utils.Avs import Utils.Avs
import Utils.Mail (pickValidEmail)
import Utils.Users import Utils.Users
import Handler.Utils.Users import Handler.Utils.Users
import Handler.Utils.Profile (validPostAddressText)
import Handler.Utils.Company import Handler.Utils.Company
import Handler.Utils.Qualification import Handler.Utils.Qualification
import Handler.Utils.Memcached import Handler.Utils.Memcached
import Database.Persist.Sql (deleteWhereCount) --, updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -139,28 +137,35 @@ catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHan
-- AVS Handlers -- -- 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 lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored! -- 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 ) => lookupAvsUser :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
-- AvsPersonId -> m (Maybe AvsDataPerson) AvsPersonId -> m (Maybe AvsDataPerson)
-- lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api) lookupAvsUser api = Map.lookup api <$> lookupAvsUsers (Set.singleton api)
-- -- | retrieves complete avs user records for given AvsPersonIds. -- | retrieves complete avs user records for given AvsPersonIds.
-- -- Note that this requires several AVS-API queries, since -- Note that this requires several AVS-API queries, since
-- -- - avsQueryPerson does not support querying an AvsPersonId directly -- - avsQueryPerson does not support querying an AvsPersonId directly
-- -- - avsQueryStatus only provides limited information -- - avsQueryStatus only provides limited information
-- -- avsQuery is used to obtain all card numbers, which are then queried separately an merged -- avsQuery is used to obtain all card numbers, which are then queried separately an merged
-- -- May throw Servant.ClientError or AvsExceptions -- May throw Servant.ClientError or AvsExceptions
-- -- Does not write to our own DB! -- Does not write to our own DB!
-- lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => lookupAvsUsers :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) =>
-- Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson) Set AvsPersonId -> m (Map AvsPersonId AvsDataPerson)
-- lookupAvsUsers apis = do lookupAvsUsers apis = do
-- AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis AvsResponseStatus statuses <- avsQuery $ AvsQueryStatus apis
-- let forFoldlM = $(permuteFun [3,2,1]) foldlM let forFoldlM = $(permuteFun [3,2,1]) foldlM
-- forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} -> forFoldlM statuses mempty $ \acc1 AvsStatusPerson{avsStatusPersonCardStatus=cards} ->
-- forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do forFoldlM cards acc1 $ \acc2 AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} -> do
-- AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo} AvsResponsePerson adps <- avsQuery $ def{avsPersonQueryCardNo = Just avsDataCardNo, avsPersonQueryVersionNo = Just avsDataVersionNo}
-- return $ mergeByPersonId adps acc2 return $ mergeByPersonId adps acc2
-- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date -- | Like `Handler.Utils.getReceivers`, but calls upsertAvsUserById on each user to ensure that postal address is up-to-date
@ -276,76 +281,9 @@ queryAvsPrimaryCard api = runMaybeT $ do
queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo) queryAvsFullCardNo :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => AvsPersonId -> m (Maybe AvsFullCardNo)
queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard queryAvsFullCardNo = fmap (fmap getFullCardNo) . queryAvsPrimaryCard
_avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
_avsFirmPostAddress = to mkPost
where
mkPost afi@AvsFirmInfo{avsFirmFirm} =
let someAddr = afi ^. _avsFirmPostAddressSimple
prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n'
in prefAddr <$> someAddr
-- | company post address without company name, better suited for comparisons
_avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
_avsFirmPostAddressSimple = to mkPost
where
mkPost AvsFirmInfo{..} =
let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
_avsFirmPrimaryEmail = to mkEmail
where
mkEmail afi =
let candidates = catMaybes
[ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
, afi ^. _avsFirmEMailSuperior
, afi ^. _avsFirmEMail
]
in pickValidEmail candidates -- should we return an invalid email rather than none?
-- | Not sure this is useful, since postal is ignored if there is no post address anyway
_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
_avsFirmPrefersPostal = to mkPostPref
where
mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
data CheckAvsUpdate record iavs = forall typ. (Eq typ, PersistField typ) => CheckAvsUpdate (EntityField record typ) (Getting typ iavs typ) -- A persistent record field and fitting getting
-- | Compute necessary updates. Given an database record, a new and an old avs response and a pair consisting of a getter from avs response to a value and and EntityField of the same value,
-- an update is returned, if the current value is identical to the old avs value, which changed in the new avs query
mkUpdate :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
mkUpdate ent new (Just old) (CheckAvsUpdate up l)
| let newval = new ^. l
, let oldval = old ^. l
, let entval = ent ^. fieldLensVal up
, newval /= entval
, oldval == entval
= Just (up =. newval)
mkUpdate _ _ _ _ = Nothing
-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited
mkUpdate' :: PersistEntity record => record -> iavs -> Maybe iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
mkUpdate' ent new Nothing = mkUpdateDirect ent new
mkUpdate' ent new just = mkUpdate ent new just
mkUpdateDirect :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> Maybe (Update record)
mkUpdateDirect ent new (CheckAvsUpdate up l)
| let newval = new ^. l
, let entval = ent ^. fieldLensVal up
, newval /= entval
= Just (up =. newval)
mkUpdateDirect _ _ _ = Nothing
-- | Unconditionally update a record through CheckAvsU
updateRecord :: PersistEntity record => record -> iavs -> CheckAvsUpdate record iavs -> record
updateRecord ent new (CheckAvsUpdate up l) =
let newval = new ^. l
lensRec = fieldLensVal up
in ent & lensRec .~ newval
-- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks -- | Like `updateAvsUserByIds`, but exceptions are not caught here to allow rollbacks
updateAvsUserById :: AvsPersonId -> DB (Maybe UserId) updateAvsUserById :: AvsPersonId -> DB (Maybe UserId)
updateAvsUserById apid = do updateAvsUserById apid = do
@ -396,23 +334,23 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here oldAvsFirmInfo = userAvsLastFirmInfo usravs -- Nothing is ok here
oldAvsCardNo = userAvsLastCardNo usravs & fmap Just oldAvsCardNo = userAvsLastCardNo usravs & fmap Just
per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo) per_ups = mapMaybe (mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo)
[ CheckAvsUpdate UserFirstName _avsInfoFirstName [ CheckUpdate UserFirstName _avsInfoFirstName
, CheckAvsUpdate UserSurname _avsInfoLastName , CheckUpdate UserSurname _avsInfoLastName
, CheckAvsUpdate UserDisplayName _avsInfoDisplayName , CheckUpdate UserDisplayName _avsInfoDisplayName
, CheckAvsUpdate UserBirthday _avsInfoDateOfBirth , CheckUpdate UserBirthday _avsInfoDateOfBirth
, CheckAvsUpdate UserMobile _avsInfoPersonMobilePhoneNo , CheckUpdate UserMobile _avsInfoPersonMobilePhoneNo
, CheckAvsUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just` , CheckUpdate UserMatrikelnummer $ _avsInfoPersonNo . re _Just -- Maybe im User, aber nicht im AvsInfo; also: `re _Just` work like `to Just`
, CheckAvsUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo , CheckUpdate UserCompanyPersonalNumber $ _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo . re _Just -- Maybe im User und im AvsInfo
] ]
em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $ em_p_up = mkUpdate' usr newAvsPersonInfo oldAvsPersonInfo $
CheckAvsUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User CheckUpdate UserDisplayEmail $ _avsInfoPersonEMail . to (fromMaybe mempty) . from _CI -- Maybe im AvsInfo, aber nicht im User
em_f_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen. em_f_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Email updates erfolgen nur, wenn identisch. Für Firmen-Email leer lassen.
CheckAvsUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI CheckUpdate UserDisplayEmail $ _avsFirmPrimaryEmail . to (fromMaybe mempty) . from _CI
eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type eml_up = em_p_up <|> em_f_up -- ensure that only one email update is produced; there is no Eq instance for the Update type
frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users, frm_up = mkUpdate' usr newAvsFirmInfo oldAvsFirmInfo $ -- Legacy, if company postal is stored in user; should no longer be true for new users,
CheckAvsUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead CheckUpdate UserPostAddress _avsFirmPostAddress -- since company address should now be referenced with UserCompany instead
pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card pin_up = mkUpdate' usr newAvsCardNo oldAvsCardNo $ -- Maybe update PDF pin to latest card
CheckAvsUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just CheckUpdate UserPinPassword $ to $ fmap avsFullCardNo2pin -- _Just . to avsFullCardNo2pin . re _Just
usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups)) usr_up1 = eml_up `mcons` (frm_up `mcons` (pin_up `mcons` per_ups))
avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons` avs_ups = ((UserAvsNoPerson =.) <$> readMay (avsInfoPersonNo newAvsPersonInfo)) `mcons`
[ UserAvsLastSynch =. now [ UserAvsLastSynch =. now
@ -422,27 +360,27 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
, UserAvsLastCardNo =. newAvsCardNo , UserAvsLastCardNo =. newAvsCardNo
] ]
-- update company association & supervision -- update company association & supervision
Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo Entity{entityKey=newCompanyId} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo oldCompanyEnt <- getAvsCompany `traverseJoin` oldAvsFirmInfo
primaryCompanyId <- getUserPrimaryCompany usrId (Just . CompanyKey . companyShorthand) primaryCompanyId <- userCompanyCompany <<$>> getUserPrimaryCompany usrId
let oldCompanyId = entityKey <$> oldCompanyEnt let oldCompanyId = entityKey <$> oldCompanyEnt
oldCompanyMb = entityVal <$> oldCompanyEnt -- oldCompanyMb = entityVal <$> oldCompanyEnt
pst_up = if -- pst_up = if
-- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines -- -- | isNothing oldCompanyMb || oldCompanyId == primaryCompanyId -- refactor could replace next 4 lines
-- -> mkUpdate' usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) -- -- -> mkUpdate' usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
| isNothing oldCompanyMb -- | isNothing oldCompanyMb
-> mkUpdateDirect usr newCompany $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though) -- -> mkUpdateDirect usr newCompany $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
| oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line -- | oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
-> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference -- -> mkUpdate usr newCompany oldCompanyMb $ CheckUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
| otherwise -- | otherwise
-> Nothing -- -> Nothing
superReasonComDef = tshow SupervisorReasonCompanyDefault superReasonComDef = tshow SupervisorReasonCompanyDefault
newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done newUserComp = UserCompany usrId newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
usr_up2 <- case oldAvsFirmInfo of usr_up2 <- case oldAvsFirmInfo of
_ | Just newCompanyId == oldCompanyId -- company unchanged entirely _ | Just newCompanyId == oldCompanyId -- company unchanged entirely
-> return Nothing -- => do nothing -> return mempty -- => do nothing
(Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR (Just oafi) | ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo -- company address unchanged OR
|| ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged || ((==) `on` view _avsFirmPrimaryEmail) oafi newAvsFirmInfo -- company primary email unchanged
-> do -- => just update user company association, keeping supervision privileges -> do -- => just update user company association, keeping supervision privileges
@ -454,31 +392,39 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
, UserSupervisorCompany ==. Just ocid -- to new company, regardless of , UserSupervisorCompany ==. Just ocid -- to new company, regardless of
, UserSupervisorReason ==. Just superReasonComDef] -- user , UserSupervisorReason ==. Just superReasonComDef] -- user
[ UserSupervisorCompany =. Just newCompanyId] [ UserSupervisorCompany =. Just newCompanyId]
return Nothing return mempty
_ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company _ | Just newCompanyId == primaryCompanyId -- old primaryCompany is now also AVS-company
-> do -> do
whenIsJust oldCompanyId $ \oldCid -> do whenIsJust oldCompanyId $ \oldCid -> do
deleteBy $ UniqueUserCompany usrId oldCid deleteBy $ UniqueUserCompany usrId oldCid
deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef) deleteWhere $ (UserSupervisorUser ==. usrId):(UserSupervisorCompany ==. oldCompanyId):(UserSupervisorReason ~=. superReasonComDef)
return Nothing return mempty
_ -- company changed completely _ -- company changed completely
-> do -> do
-- switch user company, keeping old priority (pst_up, problems) <- switchAvsUserCompany False False usrId newCompanyId
(getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case mapM_ reportAdminProblem problems
Nothing -> -- Following line does not type, hence additional parameter needed
void $ insertUnique newUserComp -- return [ u | u@Update{updateField=f} <- pst_up, f /= UserPostAddress ] -- already computed in frm_up above, duplicate update must be prevented (version above accounts for legacy updates)
Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
delete ucidOld
void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
-- adjust supervison
oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
addCompanySupervisors newCompanyId usrId
newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
return pst_up return pst_up
-- SPECIALISED CODE, PROBABLY DEPRECATED
-- switch user company, keeping old priority
-- (getBy . UniqueUserCompany usrId) `traverseJoin` oldCompanyId >>= \case
-- Nothing ->
-- void $ insertUnique newUserComp
-- Just Entity{entityKey=ucidOld, entityVal=UserCompany{userCompanyCompany, userCompanySupervisor, userCompanySupervisorReroute, userCompanyPriority}} -> do
-- when userCompanySupervisor $ reportAdminProblem $ AdminProblemSupervisorNewCompany usrId userCompanyCompany newCompanyId userCompanySupervisorReroute
-- delete ucidOld
-- void $ insertUnique newUserComp{userCompanyPriority} -- keep priority, if insert succeeds
-- -- adjust supervison
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
-- addCompanySupervisors newCompanyId usrId
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
-- return pst_up
repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors repsertSuperiorSupervisor (Just newCompanyId) newAvsFirmInfo usrId -- ensure firmInfo superior is at least normal supervisor, must be executed after updating company default supervisors
update usrId $ usr_up2 `mcons` usr_up1 -- update user eventually update usrId $ usr_up2 <> usr_up1 -- update user eventually
update uaId avs_ups -- update stored avsinfo for future updates update uaId avs_ups -- update stored avsinfo for future updates
return (apid, usrId) return (apid, usrId)
@ -647,15 +593,16 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
where where
firmInfo2company = firmInfo2company =
[ CheckAvsUpdate CompanyName $ _avsFirmFirm . from _CI [ CheckUpdate CompanyName $ _avsFirmFirm . from _CI
, CheckAvsUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI , CheckUpdate CompanyShorthand $ _avsFirmAbbreviation . from _CI
, CheckAvsUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade , CheckUpdate CompanyAvsId _avsFirmFirmNo -- Updating primary keys is always tricky, but should be okay thanks to OnUpdateCascade
-- , CheckAvsUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available -- , CheckUpdate CompanyPrefersPostal _avsFirmPrefersPostal -- Guessing here is not useful, since postal preference is ignored anyway when there is only one option available
, CheckAvsUpdate CompanyPostAddress _avsFirmPostAddress , CheckUpdate CompanyPostAddress _avsFirmPostAddress
, CheckAvsUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just , CheckUpdate CompanyEmail $ _avsFirmPrimaryEmail . _Just . from _CI . re _Just
] ]
queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler () queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler ()
queueAvsUpdateByUID uids pause = do queueAvsUpdateByUID uids pause = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime

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

@ -4,23 +4,28 @@
module Handler.Utils.Company where module Handler.Utils.Company where
import Import import Import
-- import Utils.PathPiece
-- import Data.CaseInsensitive (CI) -- import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI -- import qualified Data.CaseInsensitive as CI
-- import qualified Data.Char as Char -- import qualified Data.Char as Char
-- import qualified Data.Text as Text -- import qualified Data.Text as Text
-- import Database.Persist.Postgresql import Database.Persist.Postgresql
-- import Database.Esqueleto.Experimental ((:&)(..)) -- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.PostgreSQL as E
import Handler.Utils.Users
company2msg :: CompanyId -> SomeMessage UniWorX
company2msg = text2message . ciOriginal . unCompanyKey
-- TODO: use this function in company view Handler.Firm #157 -- TODO: use this function in company view Handler.Firm #157
-- | add all company supervisors for a given users -- | add all company supervisors for a given users
addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend) addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
=> Key Company -> Key User -> ReaderT backend m () => Key Company -> Key User -> ReaderT backend m ()
@ -44,3 +49,67 @@ addCompanySupervisors cid uid =
] ]
) )
-- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
switchAvsUserCompany usrPostAddrUpd keepOldCompanySupervs uid newCompanyId = do
usrRec <- get404 uid
newCompany <- get404 newCompanyId
mbUsrComp <- getUserPrimaryCompany uid
mbOldComp <- (get . userCompanyCompany) `traverseJoin` mbUsrComp
mbUsrAvs <- if usrPostAddrUpd then getBy (UniqueUserAvsUser uid) else return Nothing
let usrPostAddr :: Maybe StoredMarkup = userPostAddress usrRec
avsPostAddr :: Maybe StoredMarkup = mbUsrAvs ^? _Just . _entityVal . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just
usrPostUp = toMaybe (usrPostAddrUpd && fromMaybe False (liftA2 isSimilarMarkup usrPostAddr avsPostAddr))
(UserPostAddress =. Nothing) -- use company address indirectyl instead
usrPrefPost = userPrefersPostal usrRec
usrPrefPostUp = toMaybe (Just usrPrefPost == (mbOldComp ^? _Just . _companyPrefersPostal))
(UserPrefersPostal =. companyPrefersPostal newCompany)
usrUpdate = catMaybes [usrPostUp, usrPrefPostUp]
-- [UserPostAddress =. Nothing, UserPrefersPostal =. companyPrefersPostal newCompany] -- unconditional
-- update uid usrUpdate
-- repsertSuperiorSupervisor is not called here, since the Superior is indepentent of the actual company association
case mbUsrComp of
Nothing -> do -- create company user
void $ insertUnique newUserComp
addCompanySupervisors newCompanyId uid
return (usrUpdate, mempty)
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute}
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
| otherwise -> do -- switch company
void $ upsertBy (UniqueUserCompany uid newCompanyId) newUserComp
[UserCompanyPriority =. succ oldPrio, UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False, UserCompanyUseCompanyAddress =. True]
-- supervised by uid
supervisees :: [(Entity UserSupervisor, E.Value Bool)] <- E.select $ do
usrSup <- E.from $ E.table @UserSupervisor
E.where_ $ usrSup E.^. UserSupervisorSupervisor E.==. E.val uid
E.&&. usrSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
E.&&. usrSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
let singleSup = E.notExists $ do
othSup <- E.from $ E.table @UserSupervisor
E.where_ $ usrSup E.^. UserSupervisorUser E.==. othSup E.^. UserSupervisorUser
E.&&. othSup E.^. UserSupervisorCompany E.~=. E.val oldCompanyId
E.&&. othSup E.^. UserSupervisorReason E.~=. E.val superReasonComDef
return (usrSup, singleSup)
newlyUnsupervised <- guardMonoidM (notNull supervisees) $ do
E.delete $ do
usrSup <- E.from $ E.table @UserSupervisor
E.where_ $ usrSup E.^. UserSupervisorId `E.in_` E.vals (fmap (entityKey . fst) supervisees)
return $ [ AdminProblemSupervisorLeftCompany subid oldCompanyId oldSuperReroute
| (Entity{entityVal=UserSupervisor{userSupervisorUser=subid}}, E.Value True) <- supervisees ]
-- supervisors of uid
let superDeftFltr = (UserSupervisorUser ==. uid) : (UserSupervisorReason ~=. superReasonComDef)
oldSubFltr = (UserSupervisorCompany ~=. oldCompanyId) <> superDeftFltr
oldAPs <- if keepOldCompanySupervs
then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
else deleteWhereCount oldSubFltr
addCompanySupervisors newCompanyId uid
newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
$ bcons isNoLongerSupervised (AdminProblemNewlyUnsupervised uid (Just oldCompanyId) newCompanyId)
newlyUnsupervised
return (usrUpdate ,problems)
where
newUserComp = UserCompany uid newCompanyId False False 1 True -- default value for new company insertion, if no update can be done
superReasonComDef = tshow SupervisorReasonCompanyDefault

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

@ -6,22 +6,19 @@
-- TODO: consider merging with Handler.Utils.Users? -- TODO: consider merging with Handler.Utils.Users?
module Handler.Utils.Profile module Handler.Utils.Profile
( module Utils.Mail ( module Utils.Mail
, module Utils.Postal
, validDisplayName, checkDisplayName, fixDisplayName , validDisplayName, checkDisplayName, fixDisplayName
, validPostAddress, validPostAddressText
, validFraportPersonalNumber , validFraportPersonalNumber
) where ) where
import Import.NoFoundation import Import.NoFoundation
import Data.Char
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy as LT
-- import qualified Data.CaseInsensitive as CI
import qualified Data.MultiSet as MultiSet import qualified Data.MultiSet as MultiSet
import qualified Data.Set as Set import qualified Data.Set as Set
import Utils.Mail import Utils.Mail
import Utils.Postal
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname". -- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
-- Input "givennames surname" is left unchanged, except for removing excess whitespace -- Input "givennames surname" is left unchanged, except for removing excess whitespace
@ -63,23 +60,6 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s
splitAdd = Text.split isAdd splitAdd = Text.split isAdd
makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd
-- | Primitive postal address requires at least one alphabetic character, one digit and a line break
validPostAddress :: Maybe StoredMarkup -> Bool
validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr
validPostAddress _ = False
validPostAddressText :: Text -> Bool
validPostAddressText = validPostAddressLazyText . LT.fromStrict
validPostAddressLazyText :: LT.Text -> Bool
validPostAddressLazyText addr
| Just _ <- LT.find isLetter addr
, Just _ <- LT.find isNumber addr
-- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
= 1 < length (LT.lines addr)
validPostAddressLazyText _ = False
validFraportPersonalNumber :: Maybe Text -> Bool validFraportPersonalNumber :: Maybe Text -> Bool
validFraportPersonalNumber Nothing = False validFraportPersonalNumber Nothing = False
validFraportPersonalNumber (Just t) validFraportPersonalNumber (Just t)

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

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

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

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

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

@ -12,6 +12,9 @@ module Model.Types.Avs
) where ) where
import Import.NoModel hiding ((.=)) import Import.NoModel hiding ((.=))
import Model.Types.Markup
import Database.Persist.Sql import Database.Persist.Sql
import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Experimental as E
import qualified Data.Csv as Csv import qualified Data.Csv as Csv
@ -27,6 +30,9 @@ import qualified Data.Set as Set
import Data.Aeson import Data.Aeson
import Data.Aeson.Types as Aeson import Data.Aeson.Types as Aeson
import Utils.Postal (validPostAddressText)
import Utils.Mail (pickValidEmail)
{- {-
-- | Like (.:) but attempts parsing with case-insensitve keys as fallback. -- | Like (.:) but attempts parsing with case-insensitve keys as fallback.
@ -441,6 +447,9 @@ deriveJSON defaultOptions
, rejectUnknownFields = False , rejectUnknownFields = False
} ''AvsStatusPerson } ''AvsStatusPerson
makeLenses_ ''AvsStatusPerson
data AvsDataPerson = AvsDataPerson data AvsDataPerson = AvsDataPerson
{ avsPersonFirstName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces { 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 , avsPersonLastName :: Text -- WARNING: name stored as is, but AVS does contain weird whitespaces
@ -624,10 +633,41 @@ data AvsFirmInfo = AvsFirmInfo
} deriving (Eq, Ord, Show, Generic, NFData, Binary) } deriving (Eq, Ord, Show, Generic, NFData, Binary)
makeLenses_ ''AvsFirmInfo makeLenses_ ''AvsFirmInfo
-- additional convenience lenses declared in Handler.Utils.Avs due to required dependencies: -- additional convenience lenses:
-- _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
-- _avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool _avsFirmPostAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe StoredMarkup)
-- _avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text) _avsFirmPostAddress = to mkPost
where
mkPost afi@AvsFirmInfo{avsFirmFirm} =
let someAddr = afi ^. _avsFirmPostAddressSimple
prefAddr = plaintextToStoredMarkup . (avsFirmFirm <>) . Text.cons '\n'
in prefAddr <$> someAddr
-- | company post address without company name, better suited for comparisons
_avsFirmPostAddressSimple :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
_avsFirmPostAddressSimple = to mkPost
where
mkPost AvsFirmInfo{..} =
let firmAddr = composeAddress avsFirmStreetANDHouseNo avsFirmZIPCode avsFirmCity avsFirmCountry
commAddr = avsFirmCommunication ^. _Just . _avsCommunicationAddress
in asum $ [res | res@(Just addr) <- [commAddr, firmAddr], validPostAddressText addr]
_avsFirmPrimaryEmail :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo (Maybe Text)
_avsFirmPrimaryEmail = to mkEmail
where
mkEmail afi =
let candidates = catMaybes
[ afi ^. _avsFirmCommunication . _Just . _avsCommunicationEMail
, afi ^. _avsFirmEMailSuperior
, afi ^. _avsFirmEMail
]
in pickValidEmail candidates -- should we return an invalid email rather than none?
-- | Not sure this is useful, since postal is ignored if there is no post address anyway
_avsFirmPrefersPostal :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Bool
_avsFirmPrefersPostal = to mkPostPref
where
mkPostPref afi = isJust (afi ^. _avsFirmPostAddress) || isNothing (afi ^. _avsFirmPrimaryEmail)
-- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead -- Note _avsFirmAddress is never empty; always includes the company name; consider using user _avsFirmPostAddress instead
-- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text -- _avsFirmAddress :: (Profunctor p, Contravariant f) => Optic' p f AvsFirmInfo Text
@ -640,16 +680,16 @@ makeLenses_ ''AvsFirmInfo
instance FromJSON AvsFirmInfo where instance FromJSON AvsFirmInfo where
parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo parseJSON = withObject "AvsFirmInfo" $ \o -> AvsFirmInfo
<$> (o .: "Firm" <&> Text.strip) -- AVS may contain leading/trailing whitespace <$> (o .: "Firm" <&> Text.strip) -- AVS often contains leading/trailing whitespace
<*> o .: "FirmNo" <*> o .: "FirmNo"
<*> (o .: "Abbreviation" <&> Text.strip) -- AVS may contain leading/trailing whitespace <*> (o .: "Abbreviation" <&> Text.strip)
<*> o .:?! "ZIPCode" <*> (o .:?! "ZIPCode" <&> fmap Text.strip)
<*> o .:?! "City" <*> (o .:?! "City" <&> fmap Text.strip)
<*> o .:?! "Country" <*> (o .:?! "Country" <&> fmap Text.strip)
<*> o .:?! "StreetANDHouseNo" <*> (o .:?! "StreetANDHouseNo" <&> fmap Text.strip)
<*> o .:?! "EMail" <*> (o .:?! "EMail" <&> fmap Text.strip)
<*> o .:?! "EMailSuperior" <*> (o .:?! "EMailSuperior" <&> fmap Text.strip)
<*> o .:?! "Communication" <*> o .:?! "Communication"
instance ToJSON AvsFirmInfo where instance ToJSON AvsFirmInfo where
toJSON AvsFirmInfo{..} = object $ catMaybes toJSON AvsFirmInfo{..} = object $ catMaybes

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

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

6
src/Utils.hs
View File

@ -922,7 +922,6 @@ deepAlt altFst _ = altFst
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty = flip foldMap maybeEmpty = flip foldMap
-- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a` -- The more general `find :: Foldable t => (a -> Bool) -> t a -> Maybe a`
filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
filterMaybe c r@(Just x) | c x = r 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 :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM dft act mb = mb >>= maybe dft act 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 :: (Applicative m, Traversable maybe, Monad maybe) => (a -> m (maybe b)) -> maybe a -> m (maybe b)
traverseJoin f x = join <$> (f `traverse` x) traverseJoin f x = join <$> (f `traverse` x)
@ -1215,6 +1215,10 @@ shortCircuitM sc binOp mx my = do
guardM :: MonadPlus m => m Bool -> m () guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f guardM f = guard =<< f
guardMonoidM :: (Applicative f, Monoid m) => Bool -> f m -> f m
guardMonoidM False _ = pure mempty
guardMonoidM True x = x
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = x >>= assertM' f assertM f x = x >>= assertM' f

149
src/Utils/Avs.hs
View File

@ -76,25 +76,44 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
#ifdef DEVELOPMENT #ifdef DEVELOPMENT
mkAvsQuery _ _ _ = AvsQuery mkAvsQuery _ _ _ = AvsQuery
{ avsQueryPerson = { avsQueryPerson = return . Right . fakePerson
let , avsQueryStatus = return . Right . fakeStatus
sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty , avsQueryContact = return . Right . fakeContact
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)
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
, avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences 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 #else
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> if q == def then return $ Right $ AvsResponsePerson mempty else -- prevent empty queries { avsQueryPerson = \q -> if q == def then return $ Right $ AvsResponsePerson mempty else -- prevent empty queries
@ -132,7 +151,7 @@ splitQuery rawQuery q
#endif #endif
----------------------- -----------------------
-- Utility Functions -- -- Utility Functions -- DEPRECTATED
----------------------- -----------------------
-- retrieve AvsDataPersonCard with longest validity for a given licence, -- retrieve AvsDataPersonCard with longest validity for a given licence,
@ -147,58 +166,58 @@ splitQuery rawQuery q
-- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) -- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
-- | DEPRECTATED -- | DEPRECTATED
getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) -- getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
getCompanyAddress card@AvsDataPersonCard{..} -- getCompanyAddress card@AvsDataPersonCard{..}
| Just street <- avsDataStreet -- | Just street <- avsDataStreet
, Just pcode <- avsDataPostalCode -- , Just pcode <- avsDataPostalCode
, Just city <- avsDataCity -- , Just city <- avsDataCity
= (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card) -- = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card)
| isJust avsDataFirm = (avsDataFirm, Nothing, Just card) -- | isJust avsDataFirm = (avsDataFirm, Nothing, Just card)
| otherwise = (Nothing, Nothing, Nothing) -- | otherwise = (Nothing, Nothing, Nothing)
-- | From a set of card, choose the one with the most complete postal address. -- -- | From a set of card, choose the one with the most complete postal address.
-- Returns company, postal address and the associated card where the address was taken from -- -- Returns company, postal address and the associated card where the address was taken from
guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard) -- guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
guessLicenceAddress cards -- guessLicenceAddress cards
| Just c <- Set.lookupMax cards -- | Just c <- Set.lookupMax cards
, card <- Set.foldr pickLicenceAddress c cards -- , card <- Set.foldr pickLicenceAddress c cards
= getCompanyAddress card -- = getCompanyAddress card
| otherwise = (Nothing, Nothing, Nothing) -- | otherwise = (Nothing, Nothing, Nothing)
hasAddress :: AvsDataPersonCard -> Bool -- hasAddress :: AvsDataPersonCard -> Bool
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode -- hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard -- pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
pickLicenceAddress a b -- pickLicenceAddress a b
| Just r <- pickBetter' hasAddress = r -- prefer card with complete address -- | Just r <- pickBetter' hasAddress = r -- prefer card with complete address
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards -- | Just r <- pickBetter' avsDataValid = r -- prefer valid cards
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards -- | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards -- | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
| avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc. -- | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc.
| avsDataCardColor a < avsDataCardColor b = b -- | avsDataCardColor a < avsDataCardColor b = b
| avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date -- | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
| avsDataIssueDate a < avsDataIssueDate b = b -- | avsDataIssueDate a < avsDataIssueDate b = b
| avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date -- | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
| avsDataValidTo a < avsDataValidTo b = b -- | avsDataValidTo a < avsDataValidTo b = b
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm -- | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
| a <= b = b -- respect natural Ord instance -- | a <= b = b -- respect natural Ord instance
| otherwise = a -- | otherwise = a
where -- where
pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard -- pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
pickBetter' = pickBetter a b -- pickBetter' = pickBetter a b
licenceRollfeld = licence2char AvsLicenceRollfeld -- licenceRollfeld = licence2char AvsLicenceRollfeld
licenceVorfeld = licence2char AvsLicenceVorfeld -- licenceVorfeld = licence2char AvsLicenceVorfeld
{- Note: -- {- Note:
For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so -- For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering -- bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
compare a b = compareBy avsDataValid -- compare a b = compareBy avsDataValid
<> compareBy avsDataValidTo -- <> compareBy avsDataValidTo
<> compareBy avsDataIssueDate -- <> compareBy avsDataIssueDate
... -- ...
where -- where
compareBy f = compare `on` f a b -- compareBy f = compare `on` f a b
-} -- -}
-- Merges several answers by AvsPersonId, preserving all AvsPersonCards -- Merges several answers by AvsPersonId, preserving all AvsPersonCards
mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson

38
src/Utils/DB.hs
View File

@ -326,3 +326,41 @@ instance WithRunDB backend m (ReaderT backend m) where
-- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar) -- getRunnerNoLock = maybe getRunner return =<< atomically (tryReadTMVar runnerTMVar)
-- runCachedDBRunnerUsing act getRunnerNoLock -- runCachedDBRunnerUsing act getRunnerNoLock
-- A datatype for a specific heterogeneous list to compute DB updates, consisting of a persistent record field and a fitting lens
data CheckUpdate record iraw = forall typ. (Eq typ, PersistField typ) => CheckUpdate (EntityField record typ) (Getting typ iraw typ) -- A persistent record field and fitting getting
-- | Compute necessary updates. Given a database record, the new and old raw data, and a pair consisting of a getter from raw data to a value and an EntityField of the same value,
-- an update is returned, if the current value is identical to the old value, which changed in the new raw data
mkUpdate :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record)
mkUpdate ent new (Just old) (CheckUpdate up l)
| let newval = new ^. l
, let oldval = old ^. l
, let entval = ent ^. fieldLensVal up
, newval /= entval
, oldval == entval
= Just (up =. newval)
mkUpdate _ _ _ _ = Nothing
-- | Like `mkUpdate` but performs the update even if there was no old value to check if the value had been edited
mkUpdate' :: PersistEntity record => record -> iraw -> Maybe iraw -> CheckUpdate record iraw -> Maybe (Update record)
mkUpdate' ent new Nothing = mkUpdateDirect ent new
mkUpdate' ent new just = mkUpdate ent new just
mkUpdateDirect :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> Maybe (Update record)
mkUpdateDirect ent new (CheckUpdate up l)
| let newval = new ^. l
, let entval = ent ^. fieldLensVal up
, newval /= entval
= Just (up =. newval)
mkUpdateDirect _ _ _ = Nothing
-- | Unconditionally update a record through ChecUpdate
updateRecord :: PersistEntity record => record -> iraw -> CheckUpdate record iraw -> record
updateRecord ent new (CheckUpdate up l) =
let newval = new ^. l
lensRec = fieldLensVal up
in ent & lensRec .~ newval

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

@ -0,0 +1,32 @@
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile?
-- TODO: consider merging with Handler.Utils.Users?
module Utils.Postal
( validPostAddress, validPostAddressText
) where
import Import.NoModel
import Model.Types.Markup
import Data.Char
import qualified Data.Text.Lazy as LT
-- | Primitive postal address requires at least one alphabetic character, one digit and a line break
validPostAddress :: Maybe StoredMarkup -> Bool
validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr
validPostAddress _ = False
validPostAddressText :: Text -> Bool
validPostAddressText = validPostAddressLazyText . LT.fromStrict
validPostAddressLazyText :: LT.Text -> Bool
validPostAddressLazyText addr
| Just _ <- LT.find isLetter addr
, Just _ <- LT.find isNumber addr
-- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
= 1 < length (LT.lines addr)
validPostAddressLazyText _ = False

6
templates/letter/din5008.latex
View File

@ -59,6 +59,8 @@ $endfor$
\def\languageshorthands#1{} \def\languageshorthands#1{}
$endif$ $endif$
\usepackage[sfdefault]{roboto}
\ifLuaTeX \ifLuaTeX
\usepackage{selnolig} % disable illegal ligatures \usepackage{selnolig} % disable illegal ligatures
\fi \fi
@ -67,11 +69,11 @@ $endif$
\usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc}
\usepackage[utf8]{inputenc} \usepackage[utf8]{inputenc}
\usepackage{textcomp} % provide euro and other symbols \usepackage{textcomp} % provide euro and other symbols
\usepackage{DejaVuSansMono} % better monofont % \usepackage{DejaVuSansMono} % better monofont
\else \else
% if luatex or xetex % if luatex or xetex
\usepackage{fontspec} \usepackage{fontspec}
\setmonofont{DejaVu Sans Mono} % \setmonofont{DejaVu Sans Mono}
\fi \fi
\renewcommand{\familydefault}{\sfdefault} \renewcommand{\familydefault}{\sfdefault}

6
templates/letter/din5008with_pin.latex
View File

@ -63,15 +63,17 @@ $endif$
\usepackage{selnolig} % disable illegal ligatures \usepackage{selnolig} % disable illegal ligatures
\fi \fi
\usepackage[sfdefault]{roboto}
\ifPDFTeX \ifPDFTeX
\usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc}
\usepackage[utf8]{inputenc} \usepackage[utf8]{inputenc}
\usepackage{textcomp} % provide euro and other symbols \usepackage{textcomp} % provide euro and other symbols
\usepackage{DejaVuSansMono} % better monofont % \usepackage{DejaVuSansMono} % better monofont
\else \else
% if luatex or xetex % if luatex or xetex
\usepackage{fontspec} \usepackage{fontspec}
\setmonofont{DejaVu Sans Mono} % \setmonofont{DejaVu Sans Mono}
\fi \fi
\renewcommand{\familydefault}{\sfdefault} \renewcommand{\familydefault}{\sfdefault}

8
templates/letter/plain_article.latex
View File

@ -56,19 +56,21 @@ $endif$
\usepackage{selnolig} % disable illegal ligatures \usepackage{selnolig} % disable illegal ligatures
\fi \fi
\usepackage[sfdefault]{roboto}
\ifPDFTeX \ifPDFTeX
\usepackage{helvet} \usepackage{helvet}
\usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc} \usepackage[$if(fontenc)$$fontenc$$else$T1$endif$]{fontenc}
\usepackage[utf8]{inputenc} \usepackage[utf8]{inputenc}
\usepackage{textcomp}% provide euro and other symbols \usepackage{textcomp}% provide euro and other symbols
\usepackage{DejaVuSansMono}% better monofont % \usepackage{DejaVuSansMono}% better monofont
\renewcommand{\familydefault}{\sfdefault} \renewcommand{\familydefault}{\sfdefault}
\else \else
% if luatex or xetex % if luatex or xetex
\usepackage{fontspec} \usepackage{fontspec}
%\setmainfont{TeXGyreHeros}%could not install the package somehow tex-gyre in default.nix/shell.nix did not work %\setmainfont{TeXGyreHeros}%could not install the package somehow tex-gyre in default.nix/shell.nix did not work
\setmainfont{DejaVu Sans} % \setmainfont{DejaVu Sans}
\setmonofont{DejaVu Sans Mono} %\setmonofont{DejaVu Sans Mono}
\renewcommand{\familydefault}{\sfdefault} \renewcommand{\familydefault}{\sfdefault}
\fi \fi