From 4185742f380f7625cac2bbc8df5952157ec0ba63 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Thu, 30 Jul 2020 15:09:03 +0200
Subject: [PATCH] feat(course-visibility): account for visibility on
 AllocationListR

---
 src/Handler/Allocation/List.hs | 29 +++++++++++++++++++----------
 1 file changed, 19 insertions(+), 10 deletions(-)

diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs
index fc6d7e48a..dd44d557c 100644
--- a/src/Handler/Allocation/List.hs
+++ b/src/Handler/Allocation/List.hs
@@ -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
       ]