90 lines
3.0 KiB
Haskell
90 lines
3.0 KiB
Haskell
module Handler.Allocation.List
|
|
( getAllocationListR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import Handler.Utils.Table.Columns
|
|
import Handler.Utils.Table.Pagination
|
|
|
|
|
|
type AllocationTableExpr = E.SqlExpr (Entity Allocation)
|
|
type AllocationTableData = DBRow (Entity Allocation)
|
|
|
|
allocationListIdent :: Text
|
|
allocationListIdent = "allocations"
|
|
|
|
queryAllocation :: Getter AllocationTableExpr (E.SqlExpr (Entity Allocation))
|
|
queryAllocation = id
|
|
|
|
resultAllocation :: Lens' AllocationTableData (Entity Allocation)
|
|
resultAllocation = _dbrOutput
|
|
|
|
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
|
|
now <- liftIO getCurrentTime
|
|
let
|
|
dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _
|
|
dbtSQLQuery = return
|
|
|
|
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) AllocationTableData
|
|
dbtProj = return
|
|
|
|
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)
|
|
]
|
|
|
|
dbtSorting = mconcat
|
|
[ sortTerm $ queryAllocation . to (E.^. AllocationTerm)
|
|
, sortSchool $ queryAllocation . to (E.^. AllocationSchool)
|
|
, sortAllocationName $ queryAllocation . to (E.^. AllocationName)
|
|
]
|
|
|
|
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
|