chore(avs): fix qualification validity filtering
This commit is contained in:
Steffen Jost
parent
b203ededaa
commit
bac476e266
@ -21,4 +21,5 @@ RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesper
|
||||
RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
|
||||
AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
|
||||
LicenceTableChangeAvs: Im AVS ändern
|
||||
LicenceTableChangeFDrive: In FRADrive ändern
|
||||
LicenceTableGrantFDrive: In FRADrive erteilen
|
||||
LicenceTableRevokeFDrive: In FRADrive entziehen
|
||||
@ -21,4 +21,5 @@ 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.
|
||||
LicenceTableChangeAvs: Change in AVS
|
||||
LicenceTableChangeFDrive: Change within FRADrive
|
||||
LicenceTableGrantFDrive: Grant in FRADrive
|
||||
LicenceTableRevokeFDrive: Revoke in FRADrive
|
||||
|
||||
@ -286,7 +286,8 @@ instance Button UniWorX ButtonAvsSynch where
|
||||
|
||||
|
||||
data LicenceTableAction = LicenceTableChangeAvs
|
||||
| LicenceTableChangeFDrive
|
||||
| LicenceTableRevokeFDrive
|
||||
| LicenceTableGrantFDrive
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe LicenceTableAction
|
||||
@ -295,7 +296,8 @@ nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''LicenceTableAction id
|
||||
|
||||
data LicenceTableActionData = LicenceTableChangeAvsData
|
||||
| LicenceTableChangeFDriveData { licenceTableChangeFDriveEnd :: Day }
|
||||
| LicenceTableRevokeFDriveData
|
||||
| LicenceTableGrantFDriveData { licenceTableChangeFDriveEnd :: Day }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
@ -303,16 +305,16 @@ 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, AvsPersonId 12345678]
|
||||
setTo1 = Set.fromList [AvsPersonId minutes]
|
||||
setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678]
|
||||
-- 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]
|
||||
|
||||
-- (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case
|
||||
-- Right res -> return res
|
||||
-- Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
|
||||
-- redirect AdminR
|
||||
(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
|
||||
@ -343,20 +345,17 @@ getProblemAvsSynchR = do
|
||||
Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
|
||||
>> redirect ProblemAvsSynchR
|
||||
|
||||
((r0,tb0),(r1,tb1),(r2,tb2)) <- runDB $ (,,)
|
||||
((tres0,tb0),(tres1,tb1),(tres2,tb2)) <- runDB $ (,,)
|
||||
<$> mkLicenceTable "driveSynchNoLicence" AvsNoLicence setTo0 (Just LicenceTableChangeAvs)
|
||||
<*> mkLicenceTable "driveSynchVorfeld" AvsLicenceVorfeld setTo1 (Just LicenceTableChangeAvs)
|
||||
<*> mkLicenceTable "driveSynchRollfeld" AvsLicenceRollfeld setTo2 (Just LicenceTableChangeAvs)
|
||||
|
||||
-- for debugging
|
||||
let sres x = case x of
|
||||
FormSuccess (tda, ids) -> addMessage Info $ toHtml $ "Received " <> tshow (Set.size ids) <> " ids for " <> tshow tda
|
||||
_ -> pure ()
|
||||
sres r0
|
||||
sres r1
|
||||
sres r2
|
||||
-- end debugging
|
||||
|
||||
let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
|
||||
procRes _alic r@(LicenceTableChangeAvsData , _apids) = addMessage Info $ toHtml $ tshow r
|
||||
procRes _alic r@(_, _apids) = addMessage Info $ toHtml $ tshow r
|
||||
formResult tres2 $ procRes AvsLicenceRollfeld
|
||||
formResult tres1 $ procRes AvsLicenceVorfeld
|
||||
formResult tres0 $ procRes AvsNoLicence
|
||||
|
||||
siteLayoutMsg MsgAvsTitleLicenceSynch $ do
|
||||
setTitleI MsgAvsTitleLicenceSynch
|
||||
$(i18nWidgetFile "avs-synchronisation")
|
||||
@ -406,10 +405,8 @@ mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> Maybe LicenceTableAct
|
||||
mkLicenceTable dbtIdent aLic apids defAct = do
|
||||
currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
dbtStyle = def
|
||||
fltrLic qual = if
|
||||
-- | aLic == AvsNoLicence -> E.true -- could be R, F, both or none at all, but has licence in AVS
|
||||
let nowaday = utctDay now
|
||||
fltrLic qual = if
|
||||
| aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence) -- could be R, F, both or none at all, but has licence in AVS
|
||||
| otherwise -> E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence) -- if we suggest granting that licence, this join should deliver a value too
|
||||
-- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution:
|
||||
@ -422,7 +419,7 @@ mkLicenceTable dbtIdent aLic apids defAct = do
|
||||
dbtRowKey = (queryUserAvs >>> (E.^. UserAvsPersonId))
|
||||
&&& (queryQualification >>> (E.?. QualificationId))
|
||||
--dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api, quali) -> return (user, qualUsr, api, quali)
|
||||
dbtProj = dbtProjSimple $ pure . over _3 E.unValue
|
||||
dbtProj = dbtProjSimple $ pure . over _3 E.unValue -- just remove Value wrapper in 3rd element
|
||||
dbtColonnade = mconcat
|
||||
[ dbSelect (applying _2) id $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal
|
||||
, colUserNameLink AdminUserR
|
||||
@ -440,10 +437,11 @@ mkLicenceTable dbtIdent aLic apids defAct = do
|
||||
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
|
||||
, single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
|
||||
, single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue))
|
||||
]
|
||||
]
|
||||
|
||||
dbtFilter = mconcat
|
||||
[ single $ fltrUserNameEmail queryUser
|
||||
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.justVal nowaday) . (E.?. QualificationUserValidUntil)))
|
||||
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work?
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
||||
@ -452,9 +450,10 @@ mkLicenceTable dbtIdent aLic apids defAct = do
|
||||
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
|
||||
acts = mconcat
|
||||
[ singletonMap LicenceTableChangeAvs $ pure LicenceTableChangeAvsData
|
||||
, singletonMap LicenceTableChangeFDrive (LicenceTableChangeFDriveData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing)
|
||||
]
|
||||
|
||||
, if aLic == AvsNoLicence
|
||||
then singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing
|
||||
else singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
||||
@ -471,6 +470,7 @@ mkLicenceTable dbtIdent aLic apids defAct = do
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
validator = def -- & defaultSorting [SortDescBy "column-label"]
|
||||
postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool))
|
||||
-> FormResult ( LicenceTableActionData, Set AvsPersonId)
|
||||
|
||||
@ -45,6 +45,8 @@ import Handler.LMS.Userlist as Handler.LMS
|
||||
import Handler.LMS.Result as Handler.LMS
|
||||
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
|
||||
|
||||
import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
|
||||
|
||||
-- avoids repetition of local definitions
|
||||
single :: (k,a) -> Map k a
|
||||
single = uncurry Map.singleton
|
||||
@ -116,7 +118,7 @@ mkLmsAllTable isAdmin = do
|
||||
cactive = Ex.subSelectCount $ do
|
||||
quser <- Ex.from $ Ex.table @QualificationUser
|
||||
Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
|
||||
E.&&. quser Ex.^. QualificationUserValidUntil Ex.>=. E.val (utctDay now)
|
||||
E.&&. validQualification (utctDay now) quser
|
||||
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
|
||||
return (quali, cactive, cusers)
|
||||
dbtRowKey = (E.^. QualificationId)
|
||||
@ -411,7 +413,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
|
||||
, single $ fltrUserNameEmail queryUser
|
||||
, single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
|
||||
-- , single ("lms-status" , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
|
||||
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
|
||||
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
|
||||
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
|
||||
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
|
||||
if | Just renewal <- mbRenewal
|
||||
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
|
||||
|
||||
@ -6,7 +6,8 @@
|
||||
|
||||
|
||||
module Handler.Utils.Avs
|
||||
( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
|
||||
( validQualification, validQualification'
|
||||
, upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
|
||||
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
|
||||
, setLicence, setLicenceAvs, setLicencesAvs
|
||||
, retrieveDifferingLicences, computeDifferingLicences
|
||||
@ -57,6 +58,22 @@ instance Exception AvsException
|
||||
Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
|
||||
-}
|
||||
|
||||
------------------
|
||||
-- SQL Snippets --
|
||||
------------------
|
||||
|
||||
validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
|
||||
validQualification nowaday = \qualUser ->
|
||||
(E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
|
||||
,qualUser E.^. QualificationUserValidUntil)) -- currently valid
|
||||
E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked
|
||||
|
||||
validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
|
||||
validQualification' nowaday qualUser =
|
||||
(E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
|
||||
,qualUser E.?. QualificationUserValidUntil)) -- currently valid
|
||||
E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue) -- not blocked
|
||||
|
||||
|
||||
------------------
|
||||
-- AVS Handlers --
|
||||
@ -193,9 +210,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
|
||||
(quali E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
|
||||
-- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
|
||||
E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic) -- correct type of licence
|
||||
E.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
|
||||
,qualUser E.^. QualificationUserValidUntil)) -- currently valid
|
||||
E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked
|
||||
E.&&. (nowaday `validQualification` qualUser) -- currently valid and not blocked
|
||||
)
|
||||
`E.innerJoin` E.table @UserAvs
|
||||
`E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user