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

feat(course-visibility): account for visibility on AllocationListR

Browse Source
This commit is contained in:
Sarah Vaupel 2020-07-30 15:09:03 +02:00
parent 0c3f2011dd
commit 4185742f38
1 changed files with 19 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
src/Handler/Allocation/List.hs
View File

@ -5,6 +5,8 @@ module Handler.Allocation.List
) where ) where
import Import import Import
import Utils.Course (mayViewCourse')
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -23,18 +25,24 @@ queryAllocation = id
countCourses :: (Num n, PersistField n) countCourses :: (Num n, PersistField n)
=> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool)) => Maybe UserId -> AuthTagActive -> UTCTime
-> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool))
-> E.SqlExpr (Entity Allocation) -> E.SqlExpr (Entity Allocation)
-> E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value n)
countCourses addWhere allocation = E.subSelectCount . E.from $ \allocationCourse -> countCourses muid ata now addWhere allocation = E.subSelectCount . E.from $ \allocationCourse ->
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
E.&&. E.exists (E.from $ \course -> E.where_ $
course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
E.&&. mayViewCourse' muid ata now course
)
E.&&. addWhere allocationCourse E.&&. addWhere allocationCourse
queryAvailable :: Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) queryAvailable :: Maybe UserId -> AuthTagActive -> UTCTime
queryAvailable = queryAllocation . to (countCourses $ const E.true) -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
queryAvailable muid ata now = queryAllocation . to (countCourses muid ata now $ const E.true)
queryApplied :: UserId -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural)) queryApplied :: AuthTagActive -> UTCTime -> UserId -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
queryApplied uid = queryAllocation . to (\allocation -> countCourses (addWhere allocation) allocation) queryApplied ata now uid = queryAllocation . to (\allocation -> countCourses (Just uid) ata now (addWhere allocation) allocation)
where where
addWhere allocation allocationCourse addWhere allocation allocationCourse
= E.exists . E.from $ \courseApplication -> = E.exists . E.from $ \courseApplication ->
@ -61,13 +69,14 @@ allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocatio
getAllocationListR :: Handler Html getAllocationListR :: Handler Html
getAllocationListR = do getAllocationListR = do
muid <- maybeAuthId muid <- maybeAuthId
ata <- getSessionActiveAuthTags
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _ dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _
dbtSQLQuery = runReaderT $ (,,) dbtSQLQuery = runReaderT $ (,,)
<$> view queryAllocation <$> view queryAllocation
<*> view queryAvailable <*> view (queryAvailable muid ata now)
<*> view (maybe (to . const $ E.val 0) queryApplied muid) <*> view (maybe (to . const $ E.val 0) (queryApplied ata now) muid)
dbtProj :: DBRow _ -> DB AllocationTableData dbtProj :: DBRow _ -> DB AllocationTableData
dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue
@ -91,10 +100,10 @@ getAllocationListR = do
[ sortTerm $ queryAllocation . to (E.^. AllocationTerm) [ sortTerm $ queryAllocation . to (E.^. AllocationTerm)
, sortSchoolShort $ queryAllocation . to (E.^. AllocationSchool) , sortSchoolShort $ queryAllocation . to (E.^. AllocationSchool)
, sortAllocationName $ queryAllocation . to (E.^. AllocationName) , sortAllocationName $ queryAllocation . to (E.^. AllocationName)
, singletonMap "available" . SortColumn $ view queryAvailable , singletonMap "available" . SortColumn $ view (queryAvailable muid ata now)
, if , if
| Just uid <- muid | Just uid <- muid
-> singletonMap "applied" . SortColumn . view $ queryApplied uid -> singletonMap "applied" . SortColumn . view $ queryApplied ata now uid
| otherwise | otherwise
-> mempty -> mempty
] ]