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 qualified Data.CaseInsensitive as CI
import Data.List (nub)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
@ -72,61 +71,60 @@ getUsersR = do
psValidator = def psValidator = def
& defaultSorting [SortAscBy "name", SortAscBy "display-name"] & defaultSorting [SortAscBy "name", SortAscBy "display-name"]
schoolOptions = runDB $ do ((), userList) <- runDB $ do
courses <- selectList [] [Asc CourseSchool] -- >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) schoolOptions <- map (CI.original . schoolName . entityVal &&& CI.original . unSchoolKey . entityKey)
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses <$> selectList [] [Asc SchoolName]
((), userList) <- runDB $ dbTable psValidator DBTable dbTable psValidator DBTable
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
, dbtRowKey = (E.^. UserId) , dbtRowKey = (E.^. UserId)
, dbtColonnade , dbtColonnade
, dbtProj = return , dbtProj = return
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "name" [ ( "name"
, SortColumn $ \user -> user E.^. UserSurname , SortColumn $ \user -> user E.^. UserSurname
) )
, ( "display-name" , ( "display-name"
, SortColumn $ \user -> user E.^. UserDisplayName , SortColumn $ \user -> user E.^. UserDisplayName
) )
, ( "matriculation" , ( "matriculation"
, SortColumn $ \user -> user E.^. UserMatrikelnummer , SortColumn $ \user -> user E.^. UserMatrikelnummer
) )
] ]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
[ ( "user-search", FilterColumn $ \user criterion -> [ ( "user-search", FilterColumn $ \user criterion ->
-- let searchSql needle = E.castString (user E.^. UserDisplayName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) in -- 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? 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) Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `eLike` needle) eFalse (criterion :: Set.Set Text)
) )
, ( "matriculation", FilterColumn $ \user criterion -> if , ( "matriculation", FilterColumn $ \user criterion -> if
| Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> user E.^. UserMatrikelnummer `E.in_` E.valList (Set.toList criterion) | otherwise -> user E.^. UserMatrikelnummer `E.in_` E.valList (Set.toList criterion)
) )
, ( "school", FilterColumn $ \user criterion -> if , ( "school", FilterColumn $ \user criterion -> if
| Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool) | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> let schools = E.valList (Set.toList criterion) in | otherwise -> let schools = E.valList (Set.toList criterion) in
E.exists ( E.from $ \ulectr -> do E.exists ( E.from $ \ulectr -> do
E.where_ $ ulectr E.^. UserLecturerUser E.==. user E.^. UserId E.where_ $ ulectr E.^. UserLecturerUser E.==. user E.^. UserId
E.where_ $ ulectr E.^. UserLecturerSchool `E.in_` schools E.where_ $ ulectr E.^. UserLecturerSchool `E.in_` schools
) E.||. ) E.||.
E.exists ( E.from $ \uadmin -> do E.exists ( E.from $ \uadmin -> do
E.where_ $ uadmin E.^. UserAdminUser E.==. user E.^. UserId E.where_ $ uadmin E.^. UserAdminUser E.==. user E.^. UserId
E.where_ $ uadmin E.^. UserAdminSchool `E.in_` schools E.where_ $ uadmin E.^. UserAdminSchool `E.in_` schools
) )
) )
] ]
, dbtFilterUI = \mPrev -> mconcat , dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter "user-search") mPrev $ aopt (searchField True) (fslI MsgName) [ prismAForm (singletonFilter "user-search") mPrev $ aopt (searchField True) (fslI MsgName)
-- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt (searchField False) (fslI MsgMatrikelNr) -- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt (searchField False) (fslI MsgMatrikelNr)
, prismAForm (singletonFilter "matriculation" ) mPrev $ aopt matriculationField (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` selectFieldList schoolOptions) (fslI MsgCourseSchool)
--, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` schoolField) (fslI MsgCourseSchool) ]
] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = def
, dbtParams = def , dbtIdent = "users" :: Text
, dbtIdent = "users" :: Text }
}
defaultLayout $ do defaultLayout $ do
setTitleI MsgUserListTitle setTitleI MsgUserListTitle