146 lines
5.8 KiB
Haskell
146 lines
5.8 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Allocation.List
|
|
( getAllocationListR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Course (mayViewCourse)
|
|
|
|
import qualified Database.Esqueleto.Legacy 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, Natural, Natural)
|
|
|
|
allocationListIdent :: Text
|
|
allocationListIdent = "allocations"
|
|
|
|
queryAllocation :: Getter AllocationTableExpr (E.SqlExpr (Entity Allocation))
|
|
queryAllocation = id
|
|
|
|
|
|
countCourses :: (Num n, PersistField n)
|
|
=> Maybe UserId -> AuthTagActive -> UTCTime
|
|
-> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool))
|
|
-> E.SqlExpr (Entity Allocation)
|
|
-> E.SqlExpr (E.Value n)
|
|
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.just $ allocation E.^. AllocationId)
|
|
) E.&&. addWhere allocationCourse
|
|
|
|
queryAvailable :: Maybe UserId -> AuthTagActive -> UTCTime
|
|
-> Getter AllocationTableExpr (E.SqlExpr (E.Value Word64))
|
|
queryAvailable muid ata now = queryAllocation . to (countCourses muid ata now $ const E.true)
|
|
|
|
queryApplied :: AuthTagActive -> UTCTime -> UserId -> Getter AllocationTableExpr (E.SqlExpr (E.Value Word64))
|
|
queryApplied ata now uid = queryAllocation . to (\allocation -> countCourses (Just uid) ata now (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 . _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)])
|
|
|
|
allocationSchoolLink :: SchoolId -> SomeRoute UniWorX
|
|
allocationSchoolLink ssh = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "school", toPathPiece ssh)])
|
|
|
|
allocationLink :: Allocation -> SomeRoute UniWorX
|
|
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
|
|
|
getAllocationListR :: Handler Html
|
|
getAllocationListR = do
|
|
muid <- maybeAuthId
|
|
ata <- getSessionActiveAuthTags
|
|
now <- liftIO getCurrentTime
|
|
let
|
|
dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _
|
|
dbtSQLQuery = runReaderT $ (,,)
|
|
<$> view queryAllocation
|
|
<*> view (queryAvailable muid ata now)
|
|
<*> view (maybe (to . const $ E.val 0) (queryApplied ata now) muid)
|
|
|
|
dbtProj :: _ AllocationTableData
|
|
dbtProj = dbtProjId
|
|
<&> _dbrOutput . _2 %~ fromIntegral . E.unValue
|
|
<&> _dbrOutput . _3 %~ fromIntegral . E.unValue
|
|
|
|
dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)
|
|
|
|
dbtColonnade :: Colonnade Sortable _ _
|
|
dbtColonnade = mconcat
|
|
[ 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)
|
|
, sortSchoolShort $ queryAllocation . to (E.^. AllocationSchool)
|
|
, sortAllocationName $ queryAllocation . to (E.^. AllocationName)
|
|
, singletonMap "available" . SortColumn $ view (queryAvailable muid ata now)
|
|
, if
|
|
| Just uid <- muid
|
|
-> singletonMap "applied" . SortColumn . view $ queryApplied ata now uid
|
|
| otherwise
|
|
-> mempty
|
|
]
|
|
|
|
dbtFilter = mconcat
|
|
[ fltrAllocationActive now queryAllocation
|
|
, fltrTerm $ queryAllocation . to (E.^. AllocationTerm)
|
|
, fltrSchool $ queryAllocation . to (E.^. AllocationSchool)
|
|
, fltrAllocation queryAllocation
|
|
]
|
|
dbtFilterUI = mconcat
|
|
[ fltrAllocationActiveUI
|
|
, fltrTermUI
|
|
, fltrSchoolUI
|
|
, fltrAllocationUI
|
|
]
|
|
|
|
dbtStyle = def
|
|
{ dbsFilterLayout = defaultDBSFilterLayout
|
|
}
|
|
dbtParams = def
|
|
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
dbtExtraReps = []
|
|
|
|
dbtIdent = allocationListIdent
|
|
|
|
psValidator :: PSValidator _ _
|
|
psValidator = def
|
|
& defaultSorting [SortDescBy "term", SortAscBy "school-short", SortAscBy "allocation"]
|
|
|
|
table <- runDB $ dbTableWidget' psValidator DBTable{..}
|
|
|
|
siteLayoutMsg MsgAllocationListTitle $ do
|
|
setTitleI MsgAllocationListTitle
|
|
table
|