133 lines
5.2 KiB
Haskell
133 lines
5.2 KiB
Haskell
module Handler.Allocation.List
|
|
( getAllocationListR
|
|
) where
|
|
|
|
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, Natural, Natural)
|
|
|
|
allocationListIdent :: Text
|
|
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 . _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
|
|
now <- liftIO getCurrentTime
|
|
let
|
|
dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _
|
|
dbtSQLQuery = runReaderT $ (,,)
|
|
<$> view queryAllocation
|
|
<*> view queryAvailable
|
|
<*> view (maybe (to . const $ E.val 0) queryApplied muid)
|
|
|
|
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) AllocationTableData
|
|
dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) 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)
|
|
, 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
|
|
[ 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
|
|
|
|
dbtIdent = allocationListIdent
|
|
|
|
psValidator :: PSValidator _ _
|
|
psValidator = def
|
|
& defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "allocation"]
|
|
|
|
table <- runDB $ dbTableWidget' psValidator DBTable{..}
|
|
|
|
siteLayoutMsg MsgAllocationListTitle $ do
|
|
setTitleI MsgAllocationListTitle
|
|
table
|