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

chore(avs): create and link avs contact info page

Browse Source
This commit is contained in:
Steffen Jost 2023-03-31 16:11:01 +00:00
parent bb27324ee8
commit b0c211da65
9 changed files with 63 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,7 @@
# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
AvsPersonInfo: AVS Personendaten
AvsPersonId: AVS Personen Id
AvsPersonNo: AVS Personennummer
AvsCardNo: Ausweiskartennummer

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

@ -1,7 +1,7 @@
# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
AvsPersonInfo: AVS Person Info
AvsPersonId: AVS Person Id
AvsPersonNo: AVS Person Number
AvsCardNo: Card number

1
routes
View File

@ -67,6 +67,7 @@
/admin/tokens AdminTokensR GET POST
/admin/crontab AdminCrontabR GET
/admin/avs AdminAvsR GET POST
/admin/avs/#CryptoUUIDUser AdminAvsUserR GET
/admin/ldap AdminLdapR GET POST
/admin/problems AdminProblemsR GET
/admin/problems/no-contact ProblemUnreachableR GET

1
src/Foundation/Navigation.hs
View File

@ -113,6 +113,7 @@ breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just
breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR
breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR
breadcrumb AdminAvsUserR{} = i18nCrumb MsgAvsPersonInfo $ Just AdminAvsR
breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR
breadcrumb AdminProblemsR = i18nCrumb MsgProblemsHeading $ Just AdminR
breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $ Just AdminProblemsR

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

@ -9,6 +9,7 @@
module Handler.Admin.Avs
( getAdminAvsR, postAdminAvsR
, getAdminAvsUserR
, getProblemAvsSynchR, postProblemAvsSynchR
) where
@ -144,7 +145,7 @@ postAdminAvsR = do
|]
mAvsQuery <- getsYesod $ view _appAvsQuery
case mAvsQuery of
Nothing -> return mempty
Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
Just AvsQuery{..} -> do
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
@ -536,7 +537,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
[ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId)
-- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal
, colUserNameLink AdminUserR
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoCell a
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a
-- , colUserCompany
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
@ -632,4 +633,44 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet)
over _1 postprocess <$> dbTable validator DBTable{..}
over _1 postprocess <$> dbTable validator DBTable{..}
getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR uuid = do
uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mAvsQuery <- getsYesod $ view _appAvsQuery
resWgt <- case mAvsQuery of
Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
Just AvsQuery{..} -> do
mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
mbDataPerson <- lookupAvsUser userAvsPersonId
return [whamlet|
<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>Info Person Contact <br>
<i>(bevorzugt)
<dd .deflist_dd>
$case mbContact
$of Left err
Fehler: #{tshow err}
$of Right contactInfo
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
<dt .deflist__dt>PersonStatus und mehrere PersoSearch <br>
<i>(benötigt mehrere AVS Abfragen)
<dd .deflist_dd>
$maybe dataPerson <- mbDataPerson
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
$nothing
Keine Daten erhalten.
|]
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson
resWgt

2
src/Handler/LMS.hs
View File

@ -648,6 +648,6 @@ getLmsUserR uuid = do
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
siteLayout heading $ do
setTitle $ toHtml $ "Qualifkationen " <> userDisplayName
setTitle $ toHtml userDisplayName
$(widgetFile "lms-user")
-- $(i18nWidgetFile "lms-user")

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

@ -240,8 +240,8 @@ retrieveDifferingLicences' getStatus = do
] <>
[ AvsStatusPerson avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
#else
let statQry = AvsQueryStatus $ avsLicenceDifferences2LicenceIds lDiff
lStat <- if getStatus then throwLeftM $ avsQueryStatus statQry else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
let statQry = avsLicenceDifferences2LicenceIds lDiff
lStat <- if getStatus && notNull statQry then throwLeftM $ avsQueryStatus $ AvsQueryStatus statQry else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
#endif
return (lDiff, avsResponseStatusMap lStat)

7
src/Handler/Utils/Table/Cells.hs
View File

@ -380,9 +380,14 @@ qualificationBlockedCell (Just QualificationBlocked{..})
where
mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoCell = numCell . view _userAvsNoPerson
avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
avsPersonNoLinkedCell a = cell $ do
uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid)
avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
avsPersonCardCell cards = wgtCell
[whamlet|

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

@ -100,7 +100,7 @@ instance FromJSON AvsInternalPersonalNo where
instance ToJSON AvsInternalPersonalNo where
toJSON (AvsInternalPersonalNo ipn) = toJSON $ normalizeAvsInternalPersonalNo ipn
type instance Element AvsInternalPersonalNo = Char
type instance Element AvsInternalPersonalNo = Char
instance MonoFoldable AvsInternalPersonalNo where
ofoldMap f = ofoldr (mappend . f) mempty . avsInternalPersonalNo
ofoldr x y = Text.foldr x y . avsInternalPersonalNo
@ -207,7 +207,10 @@ instance ToJSON AvsPersonId where
instance Show AvsPersonId where
show = show . avsPersonId
instance Read AvsPersonId where
readPrec = fmap AvsPersonId readPrec
readPrec = fmap AvsPersonId readPrec
_AvsPersonId :: Iso AvsPersonId AvsPersonId Int Int
_AvsPersonId = iso avsPersonId AvsPersonId
-- | Non-existing default, also needed for query all ramp driving licences
avsPersonIdZero :: AvsPersonId
@ -658,7 +661,7 @@ deriveJSON defaultOptions
} ''AvsQueryPerson
newtype AvsQueryStatus = AvsQueryStatus (Set AvsPersonId)
deriving (Eq, Ord, Show, Generic)
deriving (Eq, Ord, Show, Generic)
deriveJSON defaultOptions ''AvsQueryStatus
newtype AvsQueryContact = AvsQueryContact (Set AvsObjPersonId) -- note the difference to AvsQueryStatus, which receives a list of id, whereas here we sent a list of single-field object