From f31a63422bf6897dbe16b32fc55e9be91e978dd7 Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 18 Feb 2019 20:48:57 +0100 Subject: [PATCH] Minor refactor schoolOption selection --- src/Handler/Users.hs | 106 +++++++++++++++++++++---------------------- 1 file changed, 52 insertions(+), 54 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index fe0f6d72f..f981d6a39 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -8,7 +8,6 @@ import Utils.Lens import qualified Data.CaseInsensitive as CI -import Data.List (nub) import qualified Data.Set as Set import qualified Data.Map as Map @@ -72,61 +71,60 @@ getUsersR = do psValidator = def & defaultSorting [SortAscBy "name", SortAscBy "display-name"] - schoolOptions = runDB $ do - courses <- selectList [] [Asc CourseSchool] -- >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) - optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses + ((), userList) <- runDB $ do + schoolOptions <- map (CI.original . schoolName . entityVal &&& CI.original . unSchoolKey . entityKey) + <$> selectList [] [Asc SchoolName] - ((), userList) <- runDB $ dbTable psValidator DBTable - { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) - , dbtRowKey = (E.^. UserId) - , dbtColonnade - , dbtProj = return - , dbtSorting = Map.fromList - [ ( "name" - , SortColumn $ \user -> user E.^. UserSurname - ) - , ( "display-name" - , SortColumn $ \user -> user E.^. UserDisplayName - ) - , ( "matriculation" - , SortColumn $ \user -> user E.^. UserMatrikelnummer - ) - ] - , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates - [ ( "user-search", FilterColumn $ \user criterion -> - -- let searchSql needle = E.castString (user E.^. UserDisplayName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) in - if Set.null criterion then E.val True else -- TODO: why is this condition not needed? - Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `eLike` needle) eFalse (criterion :: Set.Set Text) - ) - , ( "matriculation", FilterColumn $ \user criterion -> if - | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> user E.^. UserMatrikelnummer `E.in_` E.valList (Set.toList criterion) - ) - , ( "school", FilterColumn $ \user criterion -> if - | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> let schools = E.valList (Set.toList criterion) in - E.exists ( E.from $ \ulectr -> do - E.where_ $ ulectr E.^. UserLecturerUser E.==. user E.^. UserId - E.where_ $ ulectr E.^. UserLecturerSchool `E.in_` schools - ) E.||. - E.exists ( E.from $ \uadmin -> do - E.where_ $ uadmin E.^. UserAdminUser E.==. user E.^. UserId - E.where_ $ uadmin E.^. UserAdminSchool `E.in_` schools - ) - ) - ] - , dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter "user-search") mPrev $ aopt (searchField True) (fslI MsgName) - -- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt (searchField False) (fslI MsgMatrikelNr) - , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt matriculationField (fslI MsgMatrikelNr) + dbTable psValidator DBTable + { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) + , dbtRowKey = (E.^. UserId) + , dbtColonnade + , dbtProj = return + , dbtSorting = Map.fromList + [ ( "name" + , SortColumn $ \user -> user E.^. UserSurname + ) + , ( "display-name" + , SortColumn $ \user -> user E.^. UserDisplayName + ) + , ( "matriculation" + , SortColumn $ \user -> user E.^. UserMatrikelnummer + ) + ] + , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates + [ ( "user-search", FilterColumn $ \user criterion -> + -- let searchSql needle = E.castString (user E.^. UserDisplayName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) in + if Set.null criterion then E.val True else -- TODO: why is this condition not needed? + Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `eLike` needle) eFalse (criterion :: Set.Set Text) + ) + , ( "matriculation", FilterColumn $ \user criterion -> if + | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> user E.^. UserMatrikelnummer `E.in_` E.valList (Set.toList criterion) + ) + , ( "school", FilterColumn $ \user criterion -> if + | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> let schools = E.valList (Set.toList criterion) in + E.exists ( E.from $ \ulectr -> do + E.where_ $ ulectr E.^. UserLecturerUser E.==. user E.^. UserId + E.where_ $ ulectr E.^. UserLecturerSchool `E.in_` schools + ) E.||. + E.exists ( E.from $ \uadmin -> do + E.where_ $ uadmin E.^. UserAdminUser E.==. user E.^. UserId + E.where_ $ uadmin E.^. UserAdminSchool `E.in_` schools + ) + ) + ] + , dbtFilterUI = \mPrev -> mconcat + [ prismAForm (singletonFilter "user-search") mPrev $ aopt (searchField True) (fslI MsgName) + -- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt (searchField False) (fslI MsgMatrikelNr) + , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt matriculationField (fslI MsgMatrikelNr) - , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` (selectField schoolOptions)) (fslI MsgCourseSchool) - --, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` schoolField) (fslI MsgCourseSchool) - ] - , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - , dbtParams = def - , dbtIdent = "users" :: Text - } + , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) + ] + , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + , dbtParams = def + , dbtIdent = "users" :: Text + } defaultLayout $ do setTitleI MsgUserListTitle