chore(avs): add company sorting and filtering in avs problem resolution
This commit is contained in:
Steffen Jost
parent
913efb70ba
commit
76e9f7ff66
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -5,8 +5,43 @@ $#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
<h1>
|
||||
Use German translation
|
||||
<p>
|
||||
This page has not yet been translated to English yet.
|
||||
<h2>
|
||||
Person data of all AVS drivers
|
||||
|
||||
$if numUnknownLicenceOwners > 0
|
||||
<p>
|
||||
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: #
|
||||
<p>
|
||||
^{btnUnknownWgt}
|
||||
|
||||
$else
|
||||
<p>
|
||||
All AVS driving licence owners are also registered with FRADrive as expected.
|
||||
|
||||
<section>
|
||||
<h2>
|
||||
Nonconforming driving licence
|
||||
<p>
|
||||
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.
|
||||
<h3>
|
||||
Maneuvering area driving licence 'R' valid in FRADrive, but not in AVS
|
||||
<p>
|
||||
^{tb2}
|
||||
<h3>
|
||||
Maneuvering area driving licence 'R' invalid in FRADrive, but valid in AVS
|
||||
<p>
|
||||
^{tb1down}
|
||||
<h3>
|
||||
Apron driving licence 'F' valid in FRADrive, but not in AVS
|
||||
<p>
|
||||
^{tb1up}
|
||||
<h3>
|
||||
No valid driving licence in FRADrive, but having a driving licence in AVS
|
||||
<p>
|
||||
^{tb0}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user