diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index a26c6baf0..84c10e982 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -1,7 +1,7 @@ # SPDX-FileCopyrightText: 2022 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later - +AvsPersonInfo: AVS Personendaten AvsPersonId: AVS Personen Id AvsPersonNo: AVS Personennummer AvsCardNo: Ausweiskartennummer diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index b9138d68e..5cd51c3c3 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -1,7 +1,7 @@ # SPDX-FileCopyrightText: 2022 Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later - +AvsPersonInfo: AVS Person Info AvsPersonId: AVS Person Id AvsPersonNo: AVS Person Number AvsCardNo: Card number diff --git a/routes b/routes index 7599239cb..e8067afcf 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 6e9986238..a4920014f 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index fe17a924e..6376f8727 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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{..} \ No newline at end of file + 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| +

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

+

+
Info Person Contact
+ (bevorzugt) +
+ $case mbContact + $of Left err + Fehler: #{tshow err} + $of Right contactInfo + #{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))} +
PersonStatus und mehrere PersoSearch
+ (benötigt mehrere AVS Abfragen) +
+ $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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index f4a43fc61..a75985450 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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") diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 05e8df900..4c44017fa 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 09008cae5..bb3151d54 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -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| diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 66822d631..56666c293 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -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