From 76e9f7ff66a77bd660d5e405dad997abc3b99247 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 23 Dec 2022 17:13:32 +0100 Subject: [PATCH] chore(avs): add company sorting and filtering in avs problem resolution --- src/Handler/Admin/Avs.hs | 35 +++++++++++---- src/Handler/Utils/Table/Cells.hs | 4 ++ src/Handler/Utils/Table/Columns.hs | 14 +++++- .../i18n/avs-synchronisation/en-eu.hamlet | 43 +++++++++++++++++-- 4 files changed, 82 insertions(+), 14 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 371449e03..3357422d0 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -306,10 +306,10 @@ data LicenceTableActionData = LicenceTableChangeAvsData postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html postProblemAvsSynchR = getProblemAvsSynchR getProblemAvsSynchR = do - AvsLicenceDifferences{..} <- try retrieveDifferingLicences >>= \case - Right res -> return res - Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) - redirect AdminR + let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r) + catchAllAvs = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload + AvsLicenceDifferences{..} <- catchAllAvs' AdminR retrieveDifferingLicences + -- unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros -> runDB $ E.select $ do @@ -359,9 +359,7 @@ getProblemAvsSynchR = do addMessage Info $ text2Html $ "2: " <> tshow tres2 -- DEBUG #endif now <- liftIO getCurrentTime - let nowaday = utctDay now - catchAllAvs = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect ProblemAvsSynchR) - + let nowaday = utctDay now procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler () procRes aLic (LicenceTableChangeAvsData , apids) = catchAllAvs $ do oks <- setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids @@ -478,6 +476,17 @@ mkLicenceTable dbtIdent aLic apids = do -- $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal , colUserNameLink AdminUserR , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoCell a + -- , colUserCompany + , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid + E.orderBy [E.asc (comp E.^. CompanyName)] + return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let companies = intersperse (text2markup ", ") $ + (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' + icnSuper = text2markup " " <> icon IconSupervisor + pure $ toWgt $ mconcat companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe qualificationShortCell q , 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 @@ -489,6 +498,7 @@ mkLicenceTable dbtIdent aLic apids = do [ single $ sortUserNameLink queryUser , single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson)) , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) + , single $ sortUserCompany queryUser , single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) @@ -497,11 +507,20 @@ mkLicenceTable dbtIdent aLic apids = do dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work? + , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work? + , single ( "user-company", FilterColumn $ \(queryUser -> user) criteria -> if + | Set.null (criteria :: Set.Set Text) -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> + E.exists . E.from $ \(ucomp `E.InnerJoin` comp) -> do + E.on $ ucomp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + E.where_ $ (ucomp E.^. UserCompanyUser E.==. user E.^.UserId) + E.&&. E.any (E.hasInfix (comp E.^. CompanyName)) (E.val <$> Set.toList criteria) + ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) + , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) ] qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt (Entity qualId qual) = do diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index eabd8d596..3dced793a 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -56,6 +56,10 @@ pathPieceCell = cell . toWidget . toPathPiece sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a sqlCell act = mempty & cellContents .~ lift act +-- TODO: Formulate variant of sqlCell that types for tables having actions, i.e. MForm istead of YesodDB? +-- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a +-- sqlCell' = flip (set' cellContents) mempty + -- | Highlight table cells with warning: Is not yet implemented in frontend. markCell :: IsDBTable m a => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) markCell status condition normal x diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 62aa025d6..1136fdbe1 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -727,8 +727,9 @@ colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \he cell $ toWgt $ mconcat companies -} -colUserCompany' :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c) -colUserCompany' = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> +-- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB? +colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c) +colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu -> let uid = heu ^. hasEntity . _entityKey in sqlCell $ do companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do @@ -740,6 +741,15 @@ colUserCompany' = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \h icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies +sortUserCompany :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') +sortUserCompany queryUser = ( "user-company" + , SortColumn $ queryUser >>> (\user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId + E.where_ $ usrComp E.^. UserCompanyUser E.==. user E.^. UserId + E.orderBy [E.asc (comp E.^. CompanyName)] + return (comp E.^. CompanyName) + )) + ---------------------------- -- Colonnade manipulation -- diff --git a/templates/i18n/avs-synchronisation/en-eu.hamlet b/templates/i18n/avs-synchronisation/en-eu.hamlet index 79ed4575e..5cae60d1a 100644 --- a/templates/i18n/avs-synchronisation/en-eu.hamlet +++ b/templates/i18n/avs-synchronisation/en-eu.hamlet @@ -5,8 +5,43 @@ $# $# SPDX-License-Identifier: AGPL-3.0-or-later
-

- Use German translation -

- This page has not yet been translated to English yet. +

+ Person data of all AVS drivers + $if numUnknownLicenceOwners > 0 +

+ There are #{length unknownLicenceOwners} persons + owning a driving licence within AVS, # + which are not in the FRADrive database. # + + There are two solutions to this problem: # +

+ ^{btnUnknownWgt} + + $else +

+ All AVS driving licence owners are also registered with FRADrive as expected. + +

+

+ Nonconforming driving licence +

+ The following sections show all discrepancies + between AVS and FRADrive with respect to driving licences. # + It is recommended to adjust AVS driving licences and keep FRADrive as it is. +

+ Maneuvering area driving licence 'R' valid in FRADrive, but not in AVS +

+ ^{tb2} +

+ Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS +

+ ^{tb1down} +

+ Apron driving licence 'F' valid in FRADrive, but not in AVS +

+ ^{tb1up} +

+ No valid driving licence in FRADrive, but having a driving licence in AVS +

+ ^{tb0}