chore(avs): add company sorting and filtering in avs problem resolution

src/Handler/Admin/Avs.hs

@@ -306,10 +306,10 @@ data LicenceTableActionData =  LicenceTableChangeAvsData
 postProblemAvsSynchR,  getProblemAvsSynchR :: Handler Html
 postProblemAvsSynchR = getProblemAvsSynchR
 getProblemAvsSynchR = do  
-  AvsLicenceDifferences{..} <- try retrieveDifferingLicences >>= \case
+  let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
-    Right res -> return res
+      catchAllAvs    = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload
-    Left  err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
+  AvsLicenceDifferences{..} <- catchAllAvs' AdminR retrieveDifferingLicences
-                    redirect AdminR
+
   --  
   unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
     runDB $ E.select $ do
@@ -360,8 +360,6 @@ getProblemAvsSynchR = do
 #endif
   now <- liftIO getCurrentTime
   let nowaday = utctDay now      
-      catchAllAvs = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect ProblemAvsSynchR)
-      
       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

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

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)
+-- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB?
-colUserCompany' = sortable (Just "user-company") (i18nCell MsgTableCompany) $ \heu ->
+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 --

templates/i18n/avs-synchronisation/en-eu.hamlet

@@ -5,8 +5,43 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
-  <h1> 
+  <h2>
-    Use German translation
+    Person data of all AVS drivers
-  <p>
-    This page has not yet been translated to English yet.
 
+  $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}