chore(avs): add resolve actions to problems (WIP)
This commit is contained in:
Steffen Jost
parent
d365688ce9
commit
ce88a2d170
@ -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.
|
||||
AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
|
||||
LicenseTableChangeAvs: Im AVS ändern
|
||||
LicenseTableChangeFDrive: In FRADrive ändern
|
||||
@ -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.
|
||||
AvsCommunicationError: AVS interface returned an unexpected error.
|
||||
LicenseTableChangeAvs: Change in AVS
|
||||
LicenseTableChangeFDrive: Change within FRADrive
|
||||
@ -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{..}
|
||||
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{..}
|
||||
@ -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 )
|
||||
|
||||
Loading…
Reference in New Issue
Block a user