fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Minor refactor schoolOption selection

Browse Source
This commit is contained in:
SJost 2019-02-18 20:48:57 +01:00
parent 90d3135f15
commit f31a63422b
1 changed files with 52 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
src/Handler/Users.hs
View File

@ -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