diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 6ba4ec536..a6e1c49e0 100644 --- a/src/Handler/Users.hs +++ b/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.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid + 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 ", ") $ + 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