From ce88a2d170dc25066a6560b44c752e5160434459 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 15 Dec 2022 17:38:46 +0100 Subject: [PATCH] chore(avs): add resolve actions to problems (WIP) --- .../uniworx/categories/avs/de-de-formal.msg | 4 +- messages/uniworx/categories/avs/en-eu.msg | 4 +- src/Handler/Admin/Avs.hs | 75 +++++++++++++++---- src/Handler/Tutorial/Users.hs | 2 +- 4 files changed, 66 insertions(+), 19 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index eed6dc367..62a4d8622 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -19,4 +19,6 @@ BtnImportUnknownAvsIds: Daten unbekannter Personen importieren AvsImportIDs n@Int m@Int: AVS Persondendaten importiert: #{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. \ No newline at end of file +AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler. +LicenseTableChangeAvs: Im AVS ändern +LicenseTableChangeFDrive: In FRADrive ändern \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index 7b8d76d99..4731dec69 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -19,4 +19,6 @@ BtnImportUnknownAvsIds: Import unknown person data AvsImportIDs n m: AVS person daten importet: #{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. \ No newline at end of file +AvsCommunicationError: AVS interface returned an unexpected error. +LicenseTableChangeAvs: Change in AVS +LicenseTableChangeFDrive: Change within FRADrive \ No newline at end of file diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 53982ca99..9b0dc2fbe 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -30,6 +30,7 @@ import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Experimental as E hiding (from, on) import qualified Database.Esqueleto.Experimental as X (from, on) -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E +-- import Database.Esqueleto.Utils.TH -- avoids repetition of local definitions single :: (k,a) -> Map k a @@ -284,13 +285,29 @@ instance Button UniWorX ButtonAvsSynch where btnClasses BtnRevokeAvsLicences = [BCIsButton, BCDanger] +data LicenceTableAction = LicenseTableChangeAvs + | LicenseTableChangeFDrive + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe LicenceTableAction +instance Finite LicenceTableAction +nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''LicenceTableAction id + +data LicenceTableActionData = LicenseTableChangeAvsData + | LicenseTableChangeFDriveData + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + + postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html postProblemAvsSynchR = getProblemAvsSynchR getProblemAvsSynchR = do -- TODO: just for Testing -- now <- liftIO getCurrentTime -- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now) - -- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes] + -- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes, AvsPersonId 12345678] + -- setTo1 = Set.fromList [AvsPersonId minutes] + -- setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678] (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case Right res -> return res @@ -327,7 +344,7 @@ getProblemAvsSynchR = do >> redirect ProblemAvsSynchR ((_,tb0),(_,tb1),(_,tb2)) <- runDB $ (,,) - <$> mkLicenceTable AvsNoLicence setTo0 + <$> mkLicenceTable AvsLicenceVorfeld setTo0 <*> mkLicenceTable AvsLicenceVorfeld setTo1 <*> mkLicenceTable AvsLicenceRollfeld setTo2 @@ -352,8 +369,7 @@ queryQualUser = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 2) queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification)) queryQualification = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2) - -type LicenceTableData = DBRow (Entity User, Maybe (Entity QualificationUser), E.Value AvsPersonId) +type LicenceTableData = DBRow (Entity User, Maybe (Entity QualificationUser), AvsPersonId) resultUser :: Lens' LicenceTableData (Entity User) resultUser = _dbrOutput . _1 @@ -361,8 +377,8 @@ resultUser = _dbrOutput . _1 resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _2 . _Just -resultAvsPID :: Traversal' LicenceTableData (Entity QualificationUser) -resultAvsPID = _dbrOutput . _3 . _unValue +resultAvsPID :: Traversal' LicenceTableData AvsPersonId +resultAvsPID = _dbrOutput . _3 instance HasEntity LicenceTableData User where hasEntity = resultUser @@ -370,8 +386,10 @@ instance HasEntity LicenceTableData User where instance HasUser LicenceTableData where hasUser = resultUser . _entityVal -mkLicenceTable :: AvsLicence -> Set AvsPersonId -> DB (DBResult Handler ()) + +mkLicenceTable :: AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set UserId), Widget) mkLicenceTable aLic apids = do + currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute now <- liftIO getCurrentTime let nowaday = utctDay now dbtIdent = "drivingLicenceSynch" :: Text @@ -383,16 +401,16 @@ mkLicenceTable aLic apids = do E.where_ $ E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence) E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) return (user, qualUser, usrAvs E.^. UserAvsPersonId) - dbtRowKey ((usrAvs `E.InnerJoin` _) `E.LeftOuterJoin` _) = usrAvs E.^. UserAvsPersonId - dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? + dbtRowKey = queryUser >>> (E.^. UserId) -- ((_usrAvs `E.InnerJoin` usr) `E.LeftOuterJoin` _) = usr E.^. UserId + dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api) -> return (user, qualUsr, api) dbtColonnade = mconcat - [ dbSelect (applying _1) id (return . view resultAvsPID) + [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameLink AdminUserR - , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d - , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d - , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d + , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d + , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip - ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b + ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> cellMaybe qualificationBlockedCell b ] dbtSorting = mconcat [ single $ sortUserNameLink queryUser @@ -409,9 +427,34 @@ mkLicenceTable aLic apids = do [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) ] - dbtParams = def + acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData) + acts = mconcat + [ singletonMap LicenseTableChangeAvs $ pure LicenseTableChangeAvsData + , singletonMap LicenseTableChangeFDrive $ pure LicenseTableChangeFDriveData + ] + + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] validator = def -- & defaultSorting [SortDescBy "column-label"] - dbTable validator DBTable{..} \ No newline at end of file + postprocess :: FormResult (First LicenceTableActionData, DBFormResult UserId Bool LicenceTableData) + -> FormResult ( LicenceTableActionData, Set UserId) + postprocess inp = do + (First (Just act), usrMap) <- inp + 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 diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index ec40273ee..e92a9822c 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -86,7 +86,7 @@ postTUsersR tid ssh csh tutn = do [ ( TutorialUserGrantQualification , TutorialUserGrantQualificationData <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing - <*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing + <*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing -- does this suffice? Set to QualificationValidDuration + now ) , ( TutorialUserSendMail, pure TutorialUserSendMailData ) , ( TutorialUserDeregister, pure TutorialUserDeregisterData )