feat(allocation-list): show numbers of avail. and applied-to courses

messages/uniworx/de.msg

@@ -1521,6 +1521,8 @@ SchoolFunctionInvitationAccepted school@SchoolName renderedFunction@Text: #{rend
 
 AllocationActive: Aktiv
 AllocationName: Name
+AllocationAvailableCourses: Kurse
+AllocationAppliedCourses: Bewerbungen
 AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
 AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
 AllocationDescription: Beschreibung

src/Handler/Allocation/List.hs

@@ -5,12 +5,13 @@ module Handler.Allocation.List
 import Import
   
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 import Handler.Utils.Table.Columns
 import Handler.Utils.Table.Pagination
 
 
 type AllocationTableExpr = E.SqlExpr (Entity Allocation)
-type AllocationTableData = DBRow (Entity Allocation)
+type AllocationTableData = DBRow (Entity Allocation, Natural, Natural)
 
 allocationListIdent :: Text
 allocationListIdent = "allocations"
@@ -18,8 +19,34 @@ allocationListIdent = "allocations"
 queryAllocation :: Getter AllocationTableExpr (E.SqlExpr (Entity Allocation))
 queryAllocation = id
 
+
+countCourses :: (Num n, PersistField n)
+             => (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool)) 
+             -> E.SqlExpr (Entity Allocation)
+             -> E.SqlExpr (E.Value n)
+countCourses addWhere allocation = E.sub_select . E.from $ \allocationCourse -> do
+  E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
+       E.&&. addWhere allocationCourse
+  return E.countRows
+  
+queryAvailable :: Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
+queryAvailable = queryAllocation . to (countCourses $ const E.true)
+  
+queryApplied :: UserId -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
+queryApplied uid = queryAllocation . to (\allocation -> countCourses (addWhere allocation) allocation)
+  where
+    addWhere allocation allocationCourse
+      = E.exists . E.from $ \courseApplication ->
+          E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. allocationCourse E.^. AllocationCourseCourse
+               E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
+               E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid
+
 resultAllocation :: Lens' AllocationTableData (Entity Allocation)
-resultAllocation = _dbrOutput
+resultAllocation = _dbrOutput . _1
+
+resultAvailable, resultApplied :: Lens' AllocationTableData Natural
+resultAvailable = _dbrOutput . _2
+resultApplied = _dbrOutput . _3
 
 allocationTermLink :: TermId -> SomeRoute UniWorX
 allocationTermLink tid = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "term", toPathPiece tid)])
@@ -32,13 +59,17 @@ allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocatio
 
 getAllocationListR :: Handler Html
 getAllocationListR = do
+  muid <- maybeAuthId
   now <- liftIO getCurrentTime
   let
     dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _
-    dbtSQLQuery = return
+    dbtSQLQuery = runReaderT $ (,,)
+                    <$> view queryAllocation
+                    <*> view queryAvailable
+                    <*> view (maybe (to . const $ E.val 0) queryApplied muid)
 
     dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) AllocationTableData
-    dbtProj = return
+    dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue
 
     dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)
 
@@ -47,12 +78,24 @@ getAllocationListR = do
       [ anchorColonnade (views (resultAllocation . _entityVal . _allocationTerm) allocationTermLink) $ colTermShort (resultAllocation . _entityVal . _allocationTerm)
       , anchorColonnade (views (resultAllocation . _entityVal . _allocationSchool) allocationSchoolLink) $ colSchoolShort (resultAllocation . _entityVal . _allocationSchool)
       , anchorColonnade (views (resultAllocation . _entityVal) allocationLink) $ colAllocationName (resultAllocation . _entityVal . _allocationName)
+      , sortable (Just "available") (i18nCell MsgAllocationAvailableCourses) $ views resultAvailable i18nCell
+      , if
+          | Just _ <- muid
+            -> sortable (Just "applied") (i18nCell MsgAllocationAppliedCourses) . views resultApplied $ maybe mempty i18nCell . assertM' (> 0)
+          | otherwise
+            -> mempty
       ]
 
     dbtSorting = mconcat
       [ sortTerm $ queryAllocation . to (E.^. AllocationTerm)
       , sortSchool $ queryAllocation . to (E.^. AllocationSchool)
       , sortAllocationName $ queryAllocation . to (E.^. AllocationName)
+      , singletonMap "available" . SortColumn $ view queryAvailable
+      , if
+          | Just uid <- muid
+            -> singletonMap "applied" . SortColumn . view $ queryApplied uid
+          | otherwise
+            -> mempty
       ]
 
     dbtFilter = mconcat