chore(users): add sorting and filtering by company in users list

src/Handler/Users.hs

@@ -85,13 +85,13 @@ postUsersR = do
 --      , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
 --          (AdminUserR <$> encrypt uid)
 --          (toWgt userMatrikelnummer)
-      , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
+      , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \DBRow{ dbrOutput = Entity 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.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
-              E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid              
+              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 ", ") $ 
+            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
@@ -181,6 +181,13 @@ postUsersR = do
           , ( "ldap-sync"
             , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
             )
+          , ( "user-company"
+            , SortColumn $ \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)
+            )
           ]
       , dbtFilter    = Map.fromList -- OverloadedLists does not work with the templates
           [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
@@ -195,7 +202,7 @@ postUsersR = do
           , ( "user-email", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
               Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
               Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
-                      E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))   
+                      E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
             )
 --          , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
 --                 | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
@@ -227,17 +234,26 @@ postUsersR = do
                       in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
                 | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
             )
+          , ( "user-company", FilterColumn $ \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
           [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField  (fslI MsgName)
           , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField  (fslI MsgAdminUserIdent)
-          , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)          
+          , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
           -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField  (fslI MsgTableMatrikelNr)
+          , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
           , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
           , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment)
           , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
           , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
-          , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
+          , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)          
           ]
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = DBParamsForm
@@ -327,7 +343,7 @@ nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''UserAssimilateButton id
 
 
-  
+
 
 getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
 getAdminUserR = postAdminUserR
@@ -347,7 +363,7 @@ postAdminUserR uuid = do
         return (school, userFunction E.?. UserFunctionFunction, isAdmin)
 
       systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False] []
-      let systemFunctions = (`Set.member` systemFunctionsF) 
+      let systemFunctions = (`Set.member` systemFunctionsF)
 
       return ( user
              , setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools