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

fix(avs): fix #69 by redesigning live avs status page

Browse Source
This commit is contained in:
Steffen Jost 2024-04-26 17:50:48 +02:00
parent a5dfd5e10f
commit 697979c277
8 changed files with 183 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,11 +2,13 @@
# #
# SPDX-License-Identifier: AGPL-3.0-or-later # SPDX-License-Identifier: AGPL-3.0-or-later
AvsPersonInfo: AVS Personendaten AvsPersonInfo: AVS Personendaten
AvsPersonId: AVS Personen Id AvsPersonId: AVS Personen Id
AvsPersonNo: AVS Personennummer AvsPersonNo: AVS Personennummer
AvsPersonNoMismatch: AVS Personennummer hat sich geändert und wurde in FRADrive noch nicht aktualisiert
AvsCardNo: Ausweiskartennummer AvsCardNo: Ausweiskartennummer
AvsFirstName: Vorname AvsFirstName: Vorname
AvsLastName: Nachname AvsLastName: Nachname
AvsPrimaryCompany: Primäre Firma
AvsInternalPersonalNo: Personalnummer (nur Fraport AG) AvsInternalPersonalNo: Personalnummer (nur Fraport AG)
AvsVersionNo: Versionsnummer AvsVersionNo: Versionsnummer
AvsQueryNeeded: Benötigt Verbindung zum AVS. AvsQueryNeeded: Benötigt Verbindung zum AVS.
@ -33,6 +35,11 @@ LicenceTableChangeAvs: Im AVS ändern
LicenceTableGrantFDrive: In FRADrive erteilen LicenceTableGrantFDrive: In FRADrive erteilen
LicenceTableRevokeFDrive: In FRADrive entziehen LicenceTableRevokeFDrive: In FRADrive entziehen
TableAvsActiveCards: Gültige Ausweise TableAvsActiveCards: Gültige Ausweise
TableAvsCardValid: Aktuell gültig
TableAvsCardIssueDate: Ausgestellt am
TableAvsCardValidTo: Gültig bis
AvsCardAreas: Ausweiszusätze
AvsCardColor: Ausweisfarbe
AvsCardColorGreen: Grün AvsCardColorGreen: Grün
AvsCardColorBlue: Blau AvsCardColorBlue: Blau
AvsCardColorRed: Rot AvsCardColorRed: Rot

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

@ -1,12 +1,14 @@
# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de> # SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
# #
# SPDX-License-Identifier: AGPL-3.0-or-later # SPDX-License-Identifier: AGPL-3.0-or-later
AvsPersonInfo: AVS Person Info AvsPersonInfo: AVS person info
AvsPersonId: AVS Person Id AvsPersonId: AVS person id
AvsPersonNo: AVS Person Number AvsPersonNo: AVS person number
AvsPersonNoMismatch: AVS person number has changed and was not yet updated in FRADrive
AvsCardNo: Card number AvsCardNo: Card number
AvsFirstName: First name AvsFirstName: First name
AvsLastName: Last name AvsLastName: Last name
AvsPrimaryCompany: Primary company
AvsInternalPersonalNo: Personnel number (Fraport AG only) AvsInternalPersonalNo: Personnel number (Fraport AG only)
AvsVersionNo: Version number AvsVersionNo: Version number
AvsQueryNeeded: AVS connection required. AvsQueryNeeded: AVS connection required.
@ -33,6 +35,11 @@ LicenceTableChangeAvs: Change in AVS
LicenceTableGrantFDrive: Grant in FRADrive LicenceTableGrantFDrive: Grant in FRADrive
LicenceTableRevokeFDrive: Revoke in FRADrive LicenceTableRevokeFDrive: Revoke in FRADrive
TableAvsActiveCards: Valid Cards TableAvsActiveCards: Valid Cards
TableAvsCardValid: Currently valid
TableAvsCardIssueDate: Issued
TableAvsCardValidTo: Valid to
AvsCardAreas: Card areas
AvsCardColor: Color
AvsCardColorGreen: Green AvsCardColorGreen: Green
AvsCardColorBlue: Blue AvsCardColorBlue: Blue
AvsCardColorRed: Red AvsCardColorRed: Red

1
messages/uniworx/misc/de-de-formal.msg
View File

@ -21,6 +21,7 @@ ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv
AvsNoLicence: Keine Fahrberechtigung AvsNoLicence: Keine Fahrberechtigung
AvsLicenceVorfeld: Vorfeld Fahrberechtigung AvsLicenceVorfeld: Vorfeld Fahrberechtigung
AvsLicenceRollfeld: Rollfeld Fahrberechtigung AvsLicenceRollfeld: Rollfeld Fahrberechtigung
AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht möglich)
PaginationSize: Einträge pro Seite PaginationSize: Einträge pro Seite
PaginationPage: Angzeigte Seite PaginationPage: Angzeigte Seite

1
messages/uniworx/misc/en-eu.msg
View File

@ -21,6 +21,7 @@ ClusterVolatileQuickActionsEnabled: Quick actions enabled
AvsNoLicence: No driving licence AvsNoLicence: No driving licence
AvsLicenceVorfeld: Apron driving licence AvsLicenceVorfeld: Apron driving licence
AvsLicenceRollfeld: Maneuvering area driving licence AvsLicenceRollfeld: Maneuvering area driving licence
AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving licence)
PaginationSize: Rows per Page PaginationSize: Rows per Page
PaginationPage: Page to show PaginationPage: Page to show

2
src/Foundation/I18n.hs
View File

@ -605,7 +605,7 @@ unRenderMessage = unRenderMessage' (==)
unRenderMessageLenient :: forall a master. (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a] unRenderMessageLenient :: forall a master. (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a]
unRenderMessageLenient = unRenderMessage' cmp unRenderMessageLenient = unRenderMessage' cmp
where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode) where cmp = (==) `on` mk . under packed (concatMap $ filter Char.isAlphaNum . unidecode)
instance Default DateTimeFormatter where instance Default DateTimeFormatter where

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

@ -17,7 +17,7 @@ module Handler.Admin.Avs
import Import import Import
import qualified Control.Monad.State.Class as State import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode) -- import Data.Aeson (encode)
import qualified Data.Aeson.Encode.Pretty as Pretty -- import qualified Data.Aeson.Encode.Pretty as Pretty
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set import qualified Data.Set as Set
@ -167,8 +167,8 @@ postAdminAvsR = do
return [whamlet| return [whamlet|
<ul> <ul>
$forall p <- pns $forall p <- pns
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))} <li>^{jsonWidget p}
|] |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
mbPerson <- formResultMaybe presult (Just <<$>> procFormPerson) mbPerson <- formResultMaybe presult (Just <<$>> procFormPerson)
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
@ -179,7 +179,7 @@ postAdminAvsR = do
return [whamlet| return [whamlet|
<ul> <ul>
$forall p <- pns $forall p <- pns
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))} <li>^{jsonWidget p}
|] |]
mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus) mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)
@ -193,10 +193,10 @@ postAdminAvsR = do
$forall AvsDataContact{..} <- pns $forall AvsDataContact{..} <- pns
<li> <li>
<ul> <ul>
<li>AvsId: #{tshow avsContactPersonID} <li>AvsId: #{tshow avsContactPersonID}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))} <li>^{jsonWidget avsContactPersonInfo}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))} <li>^{jsonWidget avsContactFirmInfo}
|] |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
mbContact <- formResultMaybe cresult (Just <<$>> procFormContact) mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
@ -681,87 +681,148 @@ getAdminAvsUserR uuid = do
uid <- decrypt uuid uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
-- mbStatus <- try $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId mbStatus <- try $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
-- CONTINUE HERE -- mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed
mbDataPerson <- lookupAvsUser userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed
msgWarningTooltip <- messageI Warning MsgMessageWarning
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|] let warnBolt = messageTooltip msgWarningTooltip
heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson setTitle $ toHtml $ show userAvsNoPerson
let contactWgt = case mbContact of let contactWgt = case mbContact of
Left err -> exceptionWgt err Left err -> exceptionWgt err
Right (AvsResponseContact adcs) -> do Right (AvsResponseContact adcs) -> do
let cs = mkContactWgt <$> toList adcs let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
mconcat cs mconcat cs
mkContactWgt :: AvsDataContact -> Widget cardsWgt = case mbStatus of
mkContactWgt AvsDataContact Left err -> exceptionWgt err
{ avsContactPersonID = _api -- TODO Right (AvsResponseStatus asts) -> do
, avsContactPersonInfo = AvsPersonInfo {..} let cs = mkCardsWgt . avsStatusPersonCardStatus <$> toList asts
, avsContactFirmInfo = AvsFirmInfo { avsFirmFirm = _fname } -- TODO mconcat cs
} = -- cardsWgt = case mbDataPerson of
let licence :: AvsLicence = toEnum avsInfoRampLicence in -- TODO: show bad numbers too? -- Nothing -> mempty
[whamlet| -- Just AvsDataPerson{avsPersonPersonCards=crds} -> mkCardsWgt crds
<section .profile>
<dl .deflist.profile-dl>
<dt .deflist__dt>
_{MsgAdminUserSurname}
<dd .deflist__dd>
#{avsInfoLastName}
<dt .deflist__dt>
_{MsgAdminUserFirstName}
<dd .deflist__dd>
#{avsInfoFirstName}
$maybe bday <- avsInfoDateOfBirth
<dt .deflist__dt>
_{MsgAdminUserBirthday}
<dd .deflist__dd>
^{formatTimeW SelFormatDate bday}
<dt .deflist__dt>
_{MsgAvsLicence}
<dd .deflist__dd>
_{licence}
|]
[whamlet| [whamlet|
<p> <p>
Die Ansicht zeigt ausschließlich kürzlich vom AVS glieferte Daten: Die Ansicht zeigt ausschließlich kürzlich vom AVS abgerufene Daten:
<p> <p>
^{contactWgt} ^{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}
-- |]
<p> mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
Vorläufige Admin Ansicht AVS Daten. mkContactWgt warnBolt reqAvsNo AvsDataContact
Ansicht zeigt aktuelle Daten. { -- avsContactPersonID = _api
Es erfolgte damit aber noch kein Update der FRADrive Daten. avsContactPersonInfo = AvsPersonInfo{..}
<p> , avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
<dl .deflist> } =
<dt .deflist__dt>InfoPersonContact <br> let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
<i>(bevorzugt) [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> <dd .deflist__dd>
$case mbContact ^{formatTimeW SelFormatDate bday}
$of Left err <dt .deflist__dt>
^{exceptionWgt err} _{MsgAvsLicence}
$of Right contactInfo <dd .deflist__dd>
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))} $maybe licence <- parseAvsLicence avsInfoRampLicence
<dt .deflist__dt>PersonStatus und mehrere PersonSearch <br> _{licence}
<i>(benötigt mehrere AVS Abfragen) $nothing
<dd .deflist__dd> _{MsgAvsNoLicenceGuest}
$maybe dataPerson <- mbDataPerson |]
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
$nothing mkCardsWgt :: Set AvsDataPersonCard -> Widget
Keine Daten erhalten. mkCardsWgt crds =
<h3> [whamlet|
Provisorische formatierte Ansicht <table>
<p> <thead>
Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte. <th>_{MsgAvsCardNo}
In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar. <th>_{MsgTableAvsCardValid}
<p> <th>_{MsgAvsCardColor}
^{foldMap jsonWidget mbContact} <th>_{MsgAvsCardAreas}
<p> <th>_{MsgTableCompany}
^{foldMap jsonWidget mbDataPerson} <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}
|]
instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where
hasEntity = _dbrOutput . _2 hasEntity = _dbrOutput . _2

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

@ -23,7 +23,7 @@ module Handler.Utils.Avs
, retrieveDifferingLicences, retrieveDifferingLicencesStatus , retrieveDifferingLicences, retrieveDifferingLicencesStatus
, computeDifferingLicences , computeDifferingLicences
-- , synchAvsLicences -- , synchAvsLicences
, lookupAvsUser, lookupAvsUsers -- , lookupAvsUser, lookupAvsUsers
, AvsException(..) , AvsException(..)
, updateReceivers , updateReceivers
, AvsPersonIdMapPersonCard , AvsPersonIdMapPersonCard
@ -141,26 +141,26 @@ catchAVShandler allEx toLog toMsg dft act = act `catches` (avsHandlers <> allHan
-- TODO: delete lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored! -- TODO: delete lookupAvsUser and lookupAvsUsers once Handler.Admin.Avs.getAdminAvsUserR as refactored!
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

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

@ -25,7 +25,7 @@ import qualified Data.Set as Set
-- import qualified Data.HashMap.Lazy as HM -- import qualified Data.HashMap.Lazy as HM
import Data.Aeson import Data.Aeson
import Data.Aeson.Types import Data.Aeson.Types as Aeson
{- {-
@ -308,6 +308,10 @@ licence2char AvsNoLicence = '0'
licence2char AvsLicenceVorfeld = 'F' licence2char AvsLicenceVorfeld = 'F'
licence2char AvsLicenceRollfeld = 'R' licence2char AvsLicenceRollfeld = 'R'
parseAvsLicence :: Int -> Maybe AvsLicence
parseAvsLicence (fromJSON . Number . fromIntegral -> Aeson.Success lic) = Just lic
parseAvsLicence _ = Nothing
data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb
deriving (Eq, Ord, Read, Show, Generic, Binary) deriving (Eq, Ord, Read, Show, Generic, Binary)