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