diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 2e2a91db4..5dc27dbf8 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -17,6 +17,7 @@ AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive BtnRevokeAvsLicences: Fahrberechtigungen im AVS sofort entziehen BtnImportUnknownAvsIds: Daten unbekannter Personen importieren AvsImportIDs n@Int m@Int: AVS Persondendaten importiert: #{show n}/#{show m} +AvsSetLicences alic@AvsLicence n@Int m@Int: _{alic} im AVS gesetzt: #{show n}/#{show m} RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler. diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index bb10f4bae..c43316ceb 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -16,7 +16,8 @@ AvsPersonNoNotId: AVS person number is used in human communication only and must AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive BtnRevokeAvsLicences: Revoke AVS driving licences immediately BtnImportUnknownAvsIds: Import unknown person data -AvsImportIDs n m: AVS person daten importet: #{show n}/#{show m} +AvsImportIDs n m: AVS person data imported: #{show n}/#{show m} +AvsSetLicences alic n m: _{alic} set in AVS: #{show n}/#{show m} RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details AvsCommunicationError: AVS interface returned an unexpected error. diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index f189892ee..4b8f8b93c 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -16,3 +16,7 @@ Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"} ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv + +AvsNoLicence: Keine Fahrberechtigung +AvsLicenceVorfeld: Vorfeld Fahrberechtigung +AvsLicenceRollfeld: Rollfeld Fahrberechtigung diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 65602ed84..98cf58952 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -16,3 +16,7 @@ Months num: #{num} #{pluralEN num "Month" "Months"} Days num: #{num} #{pluralEN num "Day" "Days"} ClusterVolatileQuickActionsEnabled: Quick actions enabled + +AvsNoLicence: No driving licence +AvsLicenceVorfeld: Apron driving licence +AvsLicenceRollfeld: Maneuvering area driving licence diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 41ae25346..e1294a102 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -182,6 +182,7 @@ newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving stock (Eq, Ord, Read, Show) + -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance mkMessage ''UniWorX "messages/uniworx/misc" "de-de-formal" mkMessageAddition ''UniWorX "Test" "messages/uniworx/test" "de-de-formal" @@ -212,8 +213,6 @@ mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-for mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal" mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal" mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal" -mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal" -mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal" mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal" mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "de-de-formal" mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal" @@ -228,6 +227,10 @@ mkMessageVariant ''UniWorX ''PWHashMessage "messages/auth/pw-hash" "de" mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de" mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal" +embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages +mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal" +mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal" + instance RenderMessage UniWorX TermIdentifier where renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index dd3d727df..2c04c2a5c 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -193,10 +193,8 @@ postAdminAvsR = do ((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html -> flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld) - let procFormSetLic (aid, lic) = do - let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = AvsPersonId aid } - addMessage Info $ text2Html $ "See log for detailed errors. Query: " <> tshow (toJSON $ AvsQuerySetLicences req) - res <- try $ setLicencesAvs req + let procFormSetLic (aid, lic) = do + res <- try $ setLicenceAvs (AvsPersonId aid) lic case res of (Right True) -> return $ Just [whamlet|

Success:

Licence #{tshow (licence2char lic)} set for #{tshow aid}.|] @@ -303,19 +301,21 @@ data LicenceTableActionData = LicenceTableChangeAvsData postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html postProblemAvsSynchR = getProblemAvsSynchR -getProblemAvsSynchR = do +getProblemAvsSynchR = do + -- TODO: just for Testing -- now <- liftIO getCurrentTime -- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now) -- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes, AvsPersonId 12345678] -- setTo1 = Set.fromList [AvsPersonId minutes] -- setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678] + -- addMessageI Success $ MsgAvsSetLicences AvsLicenceVorfeld 99 1000 (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case Right res -> return res Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) redirect AdminR - + unknownLicenceOwners' <- whenNonEmpty setTo0 $ \neZeros -> runDB $ E.select $ do (toZero :& usrAvs) <- X.from $ @@ -337,11 +337,12 @@ getProblemAvsSynchR = do addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners redirect ProblemAvsSynchR Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) - (Just BtnRevokeAvsLicences) -> - try (setLicencesAvs $ Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners) - >>= \case - Right True -> addMessageI Info MsgRevokeUnknownLicencesOk - Right False -> addMessageI Error MsgRevokeUnknownLicencesFail + (Just BtnRevokeAvsLicences) -> do + let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners + no_revokes = Set.size revokes + try (setLicencesAvs revokes) >>= \case + Right no_ok | no_ok < no_revokes -> addMessageI Error MsgRevokeUnknownLicencesFail + | otherwise -> addMessageI Info MsgRevokeUnknownLicencesOk Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect ProblemAvsSynchR @@ -350,7 +351,13 @@ getProblemAvsSynchR = do <*> mkLicenceTable "driveSynchVorfeld" AvsLicenceVorfeld setTo1 (Just LicenceTableChangeAvs) <*> mkLicenceTable "driveSynchRollfeld" AvsLicenceRollfeld setTo2 (Just LicenceTableChangeAvs) let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler () - procRes _alic r@(LicenceTableChangeAvsData , _apids) = addMessage Info $ toHtml $ tshow r + procRes aLic (LicenceTableChangeAvsData , apids) = do + try (setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids) >>= \case + (Right no_ok) -> let no_req = Set.size apids + mkind = if no_ok < no_req then Warning else Success + in addMessageI mkind $ MsgAvsSetLicences aLic no_ok no_req + (Left err) -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) + redirect ProblemAvsSynchR -- reload to update all tables procRes _alic r@(_, _apids) = addMessage Info $ toHtml $ tshow r formResult tres2 $ procRes AvsLicenceRollfeld formResult tres1 $ procRes AvsLicenceVorfeld diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 6f191adfb..79c260d43 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -39,6 +39,9 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications import qualified Database.Esqueleto.Utils as E + + + -------------------- -- AVS Exceptions -- -------------------- @@ -129,15 +132,15 @@ setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => AvsPersonId -> AvsLicence -> m Bool setLicenceAvs apid lic = do let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid } - setLicencesAvs req + (1 ==) <$> setLicencesAvs req --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) => - Set AvsPersonLicence -> m Bool + Set AvsPersonLicence -> m Int setLicencesAvs persLics = do AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - aux aqsl True persLics + aux aqsl 0 persLics where aux aqsl batch0_ok pls | Set.null pls = return batch0_ok @@ -154,11 +157,11 @@ setLicencesAvs persLics = do let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs ok_ids = Set.map avsResponsePersonID ok bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient - batch1_ok = length ok == length batch1 + batch1_ok = Set.size ok forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} -> $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg -- TODO: Admin Error page - aux aqsl (batch0_ok && batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) + aux aqsl (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?) -- | Retrieve all currently valid driving licences and check against our database @@ -170,10 +173,11 @@ synchAvsLicences = do allLicences <- throwLeftM avsQueryGetAllLicences deltaLicences <- computeDifferingLicences allLicences setResponse <- setLicencesAvs deltaLicences - if setResponse + let setOk = setResponse == Set.size deltaLicences + if setOk then $logInfoS "AVS" "FRADrive Licences written to AVS successfully." else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete." - return setResponse + return setOk computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence) computeDifferingLicences argl = do diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 316bb45a8..83894ab02 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -243,6 +243,7 @@ instance FromJSON AvsLicence where parseJSON _ = pure AvsNoLicence -- we simply ignore all other values #endif + -- we assume that the Ord-Instance is respected by the SQL Backend! instance PersistField AvsLicence where toPersistValue = PersistInt64 . fromIntegral . fromEnum diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b0bfaa548..cd1a34799 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -151,6 +151,12 @@ instance HasStudyDegree a => HasStudyDegree (Entity a) where instance HasQualification a => HasQualification (Entity a) where hasQualification = _entityVal . hasQualification +instance HasQualificationUser a => HasQualificationUser (Entity a) where + hasQualificationUser = _entityVal . hasQualificationUser + +instance HasLmsUser a => HasLmsUser (Entity a) where + hasLmsUser = _entityVal . hasLmsUser + instance HasUserAvs a => HasUserAvs (Entity a) where hasUserAvs = _entityVal . hasUserAvs