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

chore(avs): add resolve actions to problems (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2022-12-15 17:38:46 +01:00
parent d365688ce9
commit ce88a2d170
4 changed files with 66 additions and 19 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

@ -20,3 +20,5 @@ AvsImportIDs n@Int m@Int: AVS Persondendaten importiert: #{show n}/#{show m}
RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt
RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler. AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
LicenseTableChangeAvs: Im AVS ändern
LicenseTableChangeFDrive: In FRADrive ändern

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

@ -20,3 +20,5 @@ AvsImportIDs n m: AVS person daten importet: #{show n}/#{show m}
RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked
RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details
AvsCommunicationError: AVS interface returned an unexpected error. AvsCommunicationError: AVS interface returned an unexpected error.
LicenseTableChangeAvs: Change in AVS
LicenseTableChangeFDrive: Change within FRADrive

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

@ -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 E hiding (from, on)
import qualified Database.Esqueleto.Experimental as X (from, on) -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as X (from, on) -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto.Utils.TH
-- avoids repetition of local definitions -- avoids repetition of local definitions
single :: (k,a) -> Map k a single :: (k,a) -> Map k a
@ -284,13 +285,29 @@ instance Button UniWorX ButtonAvsSynch where
btnClasses BtnRevokeAvsLicences = [BCIsButton, BCDanger] 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 :: Handler Html
postProblemAvsSynchR = getProblemAvsSynchR postProblemAvsSynchR = getProblemAvsSynchR
getProblemAvsSynchR = do getProblemAvsSynchR = do
-- TODO: just for Testing -- TODO: just for Testing
-- now <- liftIO getCurrentTime -- now <- liftIO getCurrentTime
-- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now) -- 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 (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case
Right res -> return res Right res -> return res
@ -327,7 +344,7 @@ getProblemAvsSynchR = do
>> redirect ProblemAvsSynchR >> redirect ProblemAvsSynchR
((_,tb0),(_,tb1),(_,tb2)) <- runDB $ (,,) ((_,tb0),(_,tb1),(_,tb2)) <- runDB $ (,,)
<$> mkLicenceTable AvsNoLicence setTo0 <$> mkLicenceTable AvsLicenceVorfeld setTo0
<*> mkLicenceTable AvsLicenceVorfeld setTo1 <*> mkLicenceTable AvsLicenceVorfeld setTo1
<*> mkLicenceTable AvsLicenceRollfeld setTo2 <*> mkLicenceTable AvsLicenceRollfeld setTo2
@ -352,8 +369,7 @@ queryQualUser = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 2)
queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification)) queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
queryQualification = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2) queryQualification = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2)
type LicenceTableData = DBRow (Entity User, Maybe (Entity QualificationUser), AvsPersonId)
type LicenceTableData = DBRow (Entity User, Maybe (Entity QualificationUser), E.Value AvsPersonId)
resultUser :: Lens' LicenceTableData (Entity User) resultUser :: Lens' LicenceTableData (Entity User)
resultUser = _dbrOutput . _1 resultUser = _dbrOutput . _1
@ -361,8 +377,8 @@ resultUser = _dbrOutput . _1
resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser) resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _2 . _Just resultQualUser = _dbrOutput . _2 . _Just
resultAvsPID :: Traversal' LicenceTableData (Entity QualificationUser) resultAvsPID :: Traversal' LicenceTableData AvsPersonId
resultAvsPID = _dbrOutput . _3 . _unValue resultAvsPID = _dbrOutput . _3
instance HasEntity LicenceTableData User where instance HasEntity LicenceTableData User where
hasEntity = resultUser hasEntity = resultUser
@ -370,8 +386,10 @@ instance HasEntity LicenceTableData User where
instance HasUser LicenceTableData where instance HasUser LicenceTableData where
hasUser = resultUser . _entityVal hasUser = resultUser . _entityVal
mkLicenceTable :: AvsLicence -> Set AvsPersonId -> DB (DBResult Handler ())
mkLicenceTable :: AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set UserId), Widget)
mkLicenceTable aLic apids = do mkLicenceTable aLic apids = do
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now let nowaday = utctDay now
dbtIdent = "drivingLicenceSynch" :: Text dbtIdent = "drivingLicenceSynch" :: Text
@ -383,16 +401,16 @@ mkLicenceTable aLic apids = do
E.where_ $ E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence) E.where_ $ E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)
E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids) E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
return (user, qualUser, usrAvs E.^. UserAvsPersonId) return (user, qualUser, usrAvs E.^. UserAvsPersonId)
dbtRowKey ((usrAvs `E.InnerJoin` _) `E.LeftOuterJoin` _) = usrAvs E.^. UserAvsPersonId dbtRowKey = queryUser >>> (E.^. UserId) -- ((_usrAvs `E.InnerJoin` usr) `E.LeftOuterJoin` _) = usr E.^. UserId
dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference? dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api) -> return (user, qualUsr, api)
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelect (applying _1) id (return . view resultAvsPID) [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameLink AdminUserR , colUserNameLink AdminUserR
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> cellMaybe dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
, sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip , 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 dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
@ -409,9 +427,34 @@ mkLicenceTable aLic apids = do
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , 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 dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
validator = def -- & defaultSorting [SortDescBy "column-label"] validator = def -- & defaultSorting [SortDescBy "column-label"]
dbTable validator DBTable{..} 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{..}

2
src/Handler/Tutorial/Users.hs
View File

@ -86,7 +86,7 @@ postTUsersR tid ssh csh tutn = do
[ ( TutorialUserGrantQualification [ ( TutorialUserGrantQualification
, TutorialUserGrantQualificationData , TutorialUserGrantQualificationData
<$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing <$> 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 ) , ( TutorialUserSendMail, pure TutorialUserSendMailData )
, ( TutorialUserDeregister, pure TutorialUserDeregisterData ) , ( TutorialUserDeregister, pure TutorialUserDeregisterData )