diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index 1756690fd..2e2a91db4 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -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 \ No newline at end of file +LicenceTableGrantFDrive: In FRADrive erteilen +LicenceTableRevokeFDrive: In FRADrive entziehen \ 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 9d6c0643c..bb10f4bae 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -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 \ No newline at end of file +LicenceTableGrantFDrive: Grant in FRADrive +LicenceTableRevokeFDrive: Revoke in FRADrive diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index feaadc911..b4bc8fc29 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 54af00732..eda13bdcd 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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 diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index c5341bad7..6f191adfb 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -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)