fraport/fradrive
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
AdminProblemsReopened n@Int: #{pluralDEeN n "Admin Probleme"} erneut eröffnet
AdminProblemNewCompany: Neue Firma aus AVS automatisch erstellt; prüfen und ggf. Standardansprechpartner eintragen
AdminProblemSupervisorNewCompany b@Bool: Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma
AdminProblemSupervisorNewCompany b@Bool: Dieser Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} wechselte zu neuer Firma
AdminProblemSupervisorLeftCompany b@Bool: Einziger Standardansprechpartner #{boolText mempty "mit Standardumleitung" b} dieses Fahrers wechselte zu neuer Firma
AdminProblemNewlyUnsupervised: Fahrer hat keinen Firmenansprechpartner mehr nach AVS Firmenwechsel zu Firma
AdminProblemUser: Betroffener
ProblemTableMarkSolved: Als erledigt markieren

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

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

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
AvsSetLicencesFailed reason@Text: Setzen der Fahrlizenz im AVS fehlgeschlagen. Grund: #{reason}
AvsIdMismatch api1@AvsPersonId api2@AvsPersonId: AVS Suche für Id #{tshow api1} lieferte stattdessen Id #{tshow api2}
AvsUserCreationFailed api@AvsPersonId: Für AVS Id #{tshow api} konnte kein neuer Benutzer angelegt werden, da es eine gemeinsame Id (z.B. Personalnummer) mit einem existierenden, aber verschiedenen Nutzer gibt.
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
AvsSetLicencesFailed reason: Set driving licence within AVS failed. Reason: #{reason}
AvsIdMismatch api1 api2: AVS search for id #{tshow api1} returned id #{tshow api2} instead
AvsUserCreationFailed api@AvsPersonId: No new user could be created for AVS Id #{tshow api}, since an existing user shares at least one id presumed as unique
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
UsersCourseSchool: Bereich
ActionNoUsersSelected: Keine Benutzer:innen ausgewählt
SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} zwingend angestoßen
SynchroniseAvsAllUsersQueued n@Int64: AVS-Synchronisation von allen #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen, welche heute noch nicht synchronisiert wurden
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
UserListTitle: Komprehensive Benutzerliste
@ -89,12 +90,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!
UserAvsSync: AVS-Synchronisieren
UserLdapSync: LDAP-Synchronisieren
AllUsersLdapSync: Alle LDAP-Synchronisieren
UserHijack: Sitzung übernehmen
UserAddSupervisor: Ansprechpartner hinzufügen
UserSetSupervisor: Ansprechpartner ersetzen
UserRemoveSupervisor: Alle Ansprechpartner entfernen
UserIsSupervisor: Ist Ansprechpartner
UserAvsSwitchCompany: Als Primärfirma verwenden
UserAvsCompanySwitched c@CompanyShorthand: Primärfirma gewechselt zu #{tshow c}
AllUsersLdapSync: Alle LDAP-Synchronisieren
AllUsersAvsSync: Alle AVS-Synchronisieren
AuthKindLDAP: Fraport AG Kennung
AuthKindPWHash: FRADrive Kennung
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
UsersCourseSchool: Department
ActionNoUsersSelected: No users selected
SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}.
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}.
SynchroniseAvsUserQueued n: Triggered forced AVS synchronisation of #{n} #{pluralEN n "user" "users"}
SynchroniseAvsAllUsersQueued n: Triggered AVS synchronisation of all #{n} #{pluralEN n "user" "users"} that were not already synchronised today
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}
SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
UserListTitle: Comprehensive list of users
AccessRightsSaved: Successfully updated permissions
@ -89,12 +90,15 @@ NewPasswordLink: Set password
UserAccountDeleteWarning: Caution, this permanently deletes users and all of their associated data. Exam results must be stored long term!
UserAvsSync: Synchronise with AVS
UserLdapSync: Synchronise with LDAP
AllUsersLdapSync: Synchronise all with LDAP
UserHijack: Hijack session
UserAddSupervisor: Add supervisor
UserSetSupervisor: Replace supervisors
UserRemoveSupervisor: Set to unsupervised
UserIsSupervisor: Is supervisor
UserAvsSwitchCompany: Use as primary company
UserAvsCompanySwitched c: Primary company switched to #{tshow c}
AllUsersLdapSync: Synchronise all with LDAP
AllUsersAvsSync: Synchronise all with AVS
AuthKindLDAP: Fraport AG account
AuthKindPWHash: FRADrive account
AuthKindNoLogin: No login

3
nix/docker/default.nix
View File

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

2
routes
View File

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

3
shell.nix
View File

@ -279,13 +279,14 @@ in pkgs.mkShell {
# busybox # for print services, but interferes with build commands in develop-shell
htop
pdftk # pdftk just for testing pdf-passwords
roboto roboto-mono
# texlive.combined.scheme-full # works
# texlive.combined.scheme-medium
# texlive.combined.scheme-small
(texlive.combine {
inherit (texlive) scheme-basic
babel-german babel-english booktabs textpos
enumitem eurosym koma-script parskip xcolor dejavu
enumitem eurosym koma-script parskip xcolor roboto xkeyval
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
-- Database stores generic Value in table ProblemLog, such that changes do not disturb old entries
-- Note that is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell
-- Note that there is no RenderMessage instance, instead see @Handler.Admin.adminProblemCell dealing with special cases instead
data AdminProblem
= AdminProblemNewCompany -- new company was noticed, presumably without supervisors
{ adminProblemCompany :: CompanyId
@ -271,8 +271,13 @@ data AdminProblem
, adminProblemCompanyNew :: CompanyId -- new company of the user
, adminProblemSupervisorReroute :: Bool -- reroute included?
}
| AdminProblemSupervisorLeftCompany
{ adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to supervisor change
, adminProblemCompany :: CompanyId -- old company
, adminProblemSupervisorReroute :: Bool -- reroute included?
}
| AdminProblemNewlyUnsupervised
{ adminProblemUser :: UserId -- user who had supervsior but no longer has
{ adminProblemUser :: UserId -- user who had a supervisor but no longer has, due to user company change
, adminProblemCompanyOld :: Maybe CompanyId -- old company
, adminProblemCompanyNew :: CompanyId -- new company of the user
}

36
src/Handler/Admin.hs
View File

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

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

@ -9,7 +9,7 @@
module Handler.Admin.Avs
( getAdminAvsR, postAdminAvsR
, getAdminAvsUserR
, getAdminAvsUserR, postAdminAvsUserR
, getProblemAvsSynchR, postProblemAvsSynchR
, getProblemAvsErrorR
) where
@ -27,7 +27,8 @@ import qualified Data.Map as Map
import Handler.Utils
import Handler.Utils.Avs
-- import Handler.Utils.Qualification
import Handler.Utils.Users (getUserPrimaryCompany)
import Handler.Utils.Company (switchAvsUserCompany)
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as E
@ -676,151 +677,202 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR uuid = do
uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
mbStatus <- try $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
-- mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed
msgWarningTooltip <- messageI Warning MsgMessageWarning
let warnBolt = messageTooltip msgWarningTooltip
heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson
let contactWgt = case mbContact of
Left err -> exceptionWgt err
Right (AvsResponseContact adcs) -> do
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
mconcat cs
cardsWgt = case mbStatus of
Left err -> exceptionWgt err
Right (AvsResponseStatus asts) -> do
let cs = mkCardsWgt . avsStatusPersonCardStatus <$> toList asts
mconcat cs
-- cardsWgt = case mbDataPerson of
-- Nothing -> mempty
-- Just AvsDataPerson{avsPersonPersonCards=crds} -> mkCardsWgt crds
[whamlet|
<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}
-- |]
data UserAvsAction = UserAvsSwitchCompany
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''UserAvsAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''UserAvsAction id
instance Button UniWorX UserAvsAction where
btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault]
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
mkContactWgt warnBolt reqAvsNo AvsDataContact
{ -- avsContactPersonID = _api
avsContactPersonInfo = AvsPersonInfo{..}
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
} =
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
[whamlet|
<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}
|]
getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR = postAdminAvsUserR
postAdminAvsUserR uuid = do
isModal <- hasCustomHeader HeaderIsModal
uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
-- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
-- mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
compDict <- if 1 >= length compsUsed
then return mempty -- switch company only sensible if there is more than one company to choose
else do
let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
switchCompFormHandler availComps _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company
switchCompFormHandler availComps mbPrime = do
let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId)
switchCompForm = (,)
<$> apopt hiddenField "" (Just uuid)
<*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) "new primary company" mbPrime
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing
switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
switchCompValidate = do
(uuid_rcvd,_) <- State.get
guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
problems <- liftHandler . runDB $ do
(usrUp, problems) <- switchAvsUserCompany True False uid cid
update uid usrUp
forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
forM_ problems (\p -> do
-- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
tell . pure =<< messageI Warning p
)
let ok = if null problems then Success else Error
tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
)
return $ wrapForm spWgt
def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
(availComps, primName, primId) <- runDB $ do
mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid
mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp
-- let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort])
comps :: [Entity Company] <- selectList [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
mkCardsWgt crds =
[whamlet|
<table>
<thead>
<th>_{MsgAvsCardNo}
<th>_{MsgTableAvsCardValid}
<th>_{MsgAvsCardColor}
<th>_{MsgAvsCardAreas}
<th>_{MsgTableCompany}
<th>_{MsgTableAvsCardIssueDate}
<th>_{MsgTableAvsCardValidTo}
<tbody>
$forall c <- crds
$with AvsDataPersonCard{avsDataValid,avsDataCardColor,avsDataCardAreas,avsDataFirm,avsDataIssueDate,avsDataValidTo} <- c
<tr>
<td>
#{tshowAvsFullCardNo (getFullCardNo c)}
<td>
#{boolSymbol avsDataValid}
<td>
_{avsDataCardColor}
<td>
$forall a <- avsDataCardAreas
#{a} #
<td>
$maybe f <- avsDataFirm
#{f}
<td>
$maybe d <- avsDataIssueDate
^{formatTimeW SelFormatDate d}
<td>
$maybe d <- avsDataValidTo
^{formatTimeW SelFormatDate d}
|]
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) ->
if null adcs
then [whamlet|_{MsgAvsPersonSearchEmpty}|]
else
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
in mconcat cs
cardsWgt = case mbStatus of
Left err -> exceptionWgt err
Right (AvsResponseStatus asts) ->
if null asts
then [whamlet|This should not occur|] -- TODO
else
let cs = mkCardsWgt compDict . avsStatusPersonCardStatus <$> toList asts
in mconcat cs
[whamlet|
<p>
^{contactWgt}
<p>
^{cardsWgt}
<p>
_{MsgAvsCurrentData}
|]
where
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
mkContactWgt warnBolt reqAvsNo AvsDataContact
{ -- avsContactPersonID = _api
avsContactPersonInfo = AvsPersonInfo{..}
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
} =
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
[whamlet|
<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
{ formAction = Just . SomeRoute $ AdminTestR
, formEncoding = emailEnctype
, formAttrs = [("uw-async-form", "")]
, formAttrs = [asyncSubmitAttr] -- equivalent to [("uw-async-form", "")]
}
now <- liftIO getCurrentTime

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

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

24
src/Handler/Users.hs
View File

@ -3,6 +3,7 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeApplications #-}
module Handler.Users
( module Handler.Users
@ -25,8 +26,13 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Database.Esqueleto.Legacy as E
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
import Handler.Profile (makeProfileData)
import qualified Yesod.Auth.Util.PasswordStore as PWStore
@ -80,7 +86,7 @@ isActionSupervisor UserSetSupervisorData{} = True
isActionSupervisor _ = False
data AllUsersAction = AllUsersLdapSync
data AllUsersAction = AllUsersLdapSync | AllUsersAvsSync
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
@ -373,7 +379,7 @@ postUsersR = do
queueAvsUpdateByUID userSet Nothing
addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet
redirectKeepGetParams UsersR
(UserHijack, Set.minView -> Just (uid, _)) ->
(UserHijack, Set.lookupMin -> Just uid) ->
hijackUser uid >>= sendResponse
(UserRemoveSupervisorData, userSet) -> do
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
@ -405,6 +411,20 @@ postUsersR = do
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
addMessageI Success MsgSynchroniseLdapAllUsersQueued
redirect UsersR
AllUsersAvsSync -> do
nowaday <- liftIO getCurrentTime <&> utctDay
n <- runDB $ Ex.insertSelectCount $ do
usr <- Ex.from $ Ex.table @User
return (AvsSync
Ex.<# (usr Ex.^. UserId)
Ex.<&> E.now_
-- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
Ex.<&> E.justVal nowaday
)
queueJob' JobSynchroniseAvsQueue
addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n
redirect UsersR
let allUsersWgt' = wrapForm allUsersWgt def
{ formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute UsersR

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

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

@ -4,23 +4,28 @@
module Handler.Utils.Company where
import Import
-- import Utils.PathPiece
-- import Data.CaseInsensitive (CI)
-- import qualified Data.CaseInsensitive as CI
-- import qualified Data.Char as Char
-- import qualified Data.Text as Text
-- import Database.Persist.Postgresql
import Database.Persist.Postgresql
-- import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.PostgreSQL as E
import Handler.Utils.Users
company2msg :: CompanyId -> SomeMessage UniWorX
company2msg = text2message . ciOriginal . unCompanyKey
-- TODO: use this function in company view Handler.Firm #157
-- | add all company supervisors for a given users
addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
=> Key Company -> Key User -> ReaderT backend m ()
@ -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?
module Handler.Utils.Profile
( module Utils.Mail
, module Utils.Postal
, validDisplayName, checkDisplayName, fixDisplayName
, validPostAddress, validPostAddressText
, validFraportPersonalNumber
) where
import Import.NoFoundation
import Data.Char
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LT
-- import qualified Data.CaseInsensitive as CI
import qualified Data.MultiSet as MultiSet
import qualified Data.Set as Set
import Utils.Mail
import Utils.Postal
-- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
-- Input "givennames surname" is left unchanged, except for removing excess whitespace
@ -63,23 +60,6 @@ validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> s
splitAdd = Text.split isAdd
makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd
-- | Primitive postal address requires at least one alphabetic character, one digit and a line break
validPostAddress :: Maybe StoredMarkup -> Bool
validPostAddress (Just StoredMarkup {markupInput = addr}) = validPostAddressLazyText addr
validPostAddress _ = False
validPostAddressText :: Text -> Bool
validPostAddressText = validPostAddressLazyText . LT.fromStrict
validPostAddressLazyText :: LT.Text -> Bool
validPostAddressLazyText addr
| Just _ <- LT.find isLetter addr
, Just _ <- LT.find isNumber addr
-- , Just _ <- LT.find ((LineSeparator ==) . generalCategory) addr -- THIS DID NOT WORK
= 1 < length (LT.lines addr)
validPostAddressLazyText _ = False
validFraportPersonalNumber :: Maybe Text -> Bool
validFraportPersonalNumber Nothing = False
validFraportPersonalNumber (Just t)

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

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

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

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

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

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

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

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

6
src/Utils.hs
View File

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

149
src/Utils/Avs.hs
View File

@ -76,25 +76,44 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery
#ifdef DEVELOPMENT
mkAvsQuery _ _ _ = AvsQuery
{ avsQueryPerson =
let
sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty
stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty
steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty
in \case
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson steffen
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> return . Right $ AvsResponsePerson steffen
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson stephan
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> return . Right $ AvsResponsePerson sarah
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> return . Right $ AvsResponsePerson $ steffen <> sarah
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> return . Right $ AvsResponsePerson $ steffen <> stephan
_ -> return . Right $ AvsResponsePerson mempty
, avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty
, avsQueryContact = \_ -> return . Right $ AvsResponseContact $ Set.singleton $ AvsDataContact (AvsPersonId 1234567) (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Lange Firma" 7 "Kurz" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
{ avsQueryPerson = return . Right . fakePerson
, avsQueryStatus = return . Right . fakeStatus
, avsQueryContact = return . Right . fakeContact
, avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty
, avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty
}
where
fakePerson :: AvsQueryPerson -> AvsResponsePerson
fakePerson =
let
sarah = Set.singleton $ AvsDataPerson "Sarah" "Vaupel" Nothing 2 (AvsPersonId 2) mempty
stephan = Set.singleton $ AvsDataPerson "Stephan" "Barth" Nothing 4 (AvsPersonId 4) mempty
steffen = Set.singleton $ AvsDataPerson "Steffen" "Jost" (Just $ mkAvsInternalPersonalNo "47138") 12345678 (AvsPersonId 12345678) mempty
sumpfi1 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 12345678) mempty
sumpfi2 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604387) mempty
sumpfi3 = Set.singleton $ AvsDataPerson "Heribert" "Sumpfmeier" Nothing 12345678 (AvsPersonId 604591) mempty
in \case
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson steffen
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00001234")} -> AvsResponsePerson steffen
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00009944"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson stephan
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00003344"), avsPersonQueryVersionNo=Just "1"} -> AvsResponsePerson sarah
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "34")} -> AvsResponsePerson $ steffen <> sarah
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "4") , avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ steffen <> stephan
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00006666"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00007777"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
AvsQueryPerson{avsPersonQueryCardNo=Just (AvsCardNo "00008888"), avsPersonQueryVersionNo=Just "4"} -> AvsResponsePerson $ sumpfi1 <> sumpfi2 <> sumpfi3
_ -> AvsResponsePerson mempty
fakeStatus :: AvsQueryStatus -> AvsResponseStatus
fakeStatus (AvsQueryStatus (Set.toList -> (api:_))) = AvsResponseStatus $ Set.singleton $ AvsStatusPerson api $ Set.fromList
[ AvsDataPersonCard True (Just $ fromGregorian 2026 5 1) Nothing AvsCardColorGelb (Set.fromList ['F','R','C']) Nothing Nothing Nothing (Just "Fraport AG") (AvsCardNo "6666") "4"
, AvsDataPersonCard False (Just $ fromGregorian 2025 6 2) Nothing AvsCardColorRot (Set.fromList ['F','A' ]) Nothing Nothing Nothing (Just "N*ICE Aircraft Services & Support GmbH") (AvsCardNo "7777") "4"
, AvsDataPersonCard True (Just $ fromGregorian 2028 7 3) Nothing AvsCardColorBlau mempty Nothing Nothing Nothing (Just "Fraport Facility Services GmbH") (AvsCardNo "8888") "4"
]
fakeStatus _ = AvsResponseStatus mempty
fakeContact :: AvsQueryContact -> AvsResponseContact
fakeContact (AvsQueryContact (Set.toList -> ((AvsObjPersonId api):_))) = AvsResponseContact $ Set.singleton $ AvsDataContact api (AvsPersonInfo "123123123" "Heribert" "Sumpfmeier" (-1) Nothing Nothing Nothing Nothing) (AvsFirmInfo "Fraport AG" 7 "Fraport" Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
fakeContact _ = AvsResponseContact mempty
#else
mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery
{ avsQueryPerson = \q -> if q == def then return $ Right $ AvsResponsePerson mempty else -- prevent empty queries
@ -132,7 +151,7 @@ splitQuery rawQuery q
#endif
-----------------------
-- Utility Functions --
-- Utility Functions -- DEPRECTATED
-----------------------
-- retrieve AvsDataPersonCard with longest validity for a given licence,
@ -147,58 +166,58 @@ splitQuery rawQuery q
-- avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
-- | DEPRECTATED
getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
getCompanyAddress card@AvsDataPersonCard{..}
| Just street <- avsDataStreet
, Just pcode <- avsDataPostalCode
, Just city <- avsDataCity
= (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card)
| isJust avsDataFirm = (avsDataFirm, Nothing, Just card)
| otherwise = (Nothing, Nothing, Nothing)
-- getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
-- getCompanyAddress card@AvsDataPersonCard{..}
-- | Just street <- avsDataStreet
-- , Just pcode <- avsDataPostalCode
-- , Just city <- avsDataCity
-- = (avsDataFirm, Just $ Text.unlines $ mcons avsDataFirm [street, Text.unwords [pcode, city]], Just card)
-- | isJust avsDataFirm = (avsDataFirm, Nothing, Just card)
-- | otherwise = (Nothing, Nothing, Nothing)
-- | From a set of card, choose the one with the most complete postal address.
-- Returns company, postal address and the associated card where the address was taken from
guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
guessLicenceAddress cards
| Just c <- Set.lookupMax cards
, card <- Set.foldr pickLicenceAddress c cards
= getCompanyAddress card
| otherwise = (Nothing, Nothing, Nothing)
-- -- | From a set of card, choose the one with the most complete postal address.
-- -- Returns company, postal address and the associated card where the address was taken from
-- guessLicenceAddress :: Set AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
-- guessLicenceAddress cards
-- | Just c <- Set.lookupMax cards
-- , card <- Set.foldr pickLicenceAddress c cards
-- = getCompanyAddress card
-- | otherwise = (Nothing, Nothing, Nothing)
hasAddress :: AvsDataPersonCard -> Bool
hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
-- hasAddress :: AvsDataPersonCard -> Bool
-- hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode
pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
pickLicenceAddress a b
| Just r <- pickBetter' hasAddress = r -- prefer card with complete address
| Just r <- pickBetter' avsDataValid = r -- prefer valid cards
| Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
| Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
| avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc.
| avsDataCardColor a < avsDataCardColor b = b
| avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
| avsDataIssueDate a < avsDataIssueDate b = b
| avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
| avsDataValidTo a < avsDataValidTo b = b
| Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
| a <= b = b -- respect natural Ord instance
| otherwise = a
where
pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
pickBetter' = pickBetter a b
licenceRollfeld = licence2char AvsLicenceRollfeld
licenceVorfeld = licence2char AvsLicenceVorfeld
-- pickLicenceAddress :: AvsDataPersonCard -> AvsDataPersonCard -> AvsDataPersonCard
-- pickLicenceAddress a b
-- | Just r <- pickBetter' hasAddress = r -- prefer card with complete address
-- | Just r <- pickBetter' avsDataValid = r -- prefer valid cards
-- | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r -- prefer 'R' cards
-- | Just r <- pickBetter' (Set.member licenceVorfeld . avsDataCardAreas) = r -- prefer 'F' cards
-- | avsDataCardColor a > avsDataCardColor b = a -- prefer Yellow over Green, etc.
-- | avsDataCardColor a < avsDataCardColor b = b
-- | avsDataIssueDate a > avsDataIssueDate b = a -- prefer later issue date
-- | avsDataIssueDate a < avsDataIssueDate b = b
-- | avsDataValidTo a > avsDataValidTo b = a -- prefer later validto date
-- | avsDataValidTo a < avsDataValidTo b = b
-- | Just r <- pickBetter' (isJust . avsDataFirm) = r -- prefer having a firm
-- | a <= b = b -- respect natural Ord instance
-- | otherwise = a
-- where
-- pickBetter' :: (AvsDataPersonCard -> Bool) -> Maybe AvsDataPersonCard
-- pickBetter' = pickBetter a b
-- licenceRollfeld = licence2char AvsLicenceRollfeld
-- licenceVorfeld = licence2char AvsLicenceVorfeld
{- Note:
For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
compare a b = compareBy avsDataValid
<> compareBy avsDataValidTo
<> compareBy avsDataIssueDate
...
where
compareBy f = compare `on` f a b
-}
-- {- Note:
-- For Semigroup Ordering, (<>) ignores the righthand side except for EQ; this could conveniently be used like so
-- bestAddress :: AvsDataPersonCard -> AvsDataPersonCard -> Ordering
-- compare a b = compareBy avsDataValid
-- <> compareBy avsDataValidTo
-- <> compareBy avsDataIssueDate
-- ...
-- where
-- compareBy f = compare `on` f a b
-- -}
-- Merges several answers by AvsPersonId, preserving all AvsPersonCards
mergeByPersonId :: Set AvsDataPerson -> Map AvsPersonId AvsDataPerson -> Map AvsPersonId AvsDataPerson

38
src/Utils/DB.hs
View File

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

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

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

6
templates/letter/din5008.latex
View File

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

6
templates/letter/din5008with_pin.latex
View File

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

8
templates/letter/plain_article.latex
View File

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