Merge branch 'feat/pagination'
This commit is contained in:
Gregor Kleen
commit
d5f773317f
@ -51,3 +51,5 @@ NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs
|
||||
|
||||
HomeHeading: Startseite
|
||||
TermsHeading: Semesterübersicht
|
||||
|
||||
NumCourses n@Int64: #{tshow n} Kurse
|
||||
@ -8,6 +8,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Handler.Sheet where
|
||||
|
||||
@ -209,10 +210,10 @@ getSShowR tid csh shn = do
|
||||
-- return desired columns
|
||||
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = mconcat
|
||||
[ sortable (Just "type") "Typ" $ \(_, (_,_, E.Value ftype)) -> textCell $ toPathPiece ftype
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell (\(_, (E.Value fName,_,E.Value fType)) -> CSheetR tid csh shn (SFileR fType fName))
|
||||
(\(_, (E.Value fName,_,_)) -> str2widget fName)
|
||||
, sortable (Just "time") "Modifikation" $ \(_, (_,E.Value modified,_)) -> stringCell $ formatTimeGerWDT modified
|
||||
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
|
||||
(\(E.Value fName,_,_) -> str2widget fName)
|
||||
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
|
||||
]
|
||||
fileTable <- dbTable def $ DBTable
|
||||
{ dbtSQLQuery = fileData
|
||||
|
||||
@ -238,9 +238,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
-- Maybe construct a table to display uploaded archive files
|
||||
let colonnadeFiles cid = mconcat
|
||||
-- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
[ sortable (Just "path") "Dateiname" $ anchorCell (\(_, (Entity _ File{..})) -> SubmissionDownloadSingleR cid fileTitle)
|
||||
(\(_, (Entity _ File{..})) -> str2widget fileTitle)
|
||||
, sortable (Just "time") "Modifikation" $ \(_, (Entity _ File{..})) -> stringCell $ formatTimeGerWDT fileModified
|
||||
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle)
|
||||
(\(Entity _ File{..}) -> str2widget fileTitle)
|
||||
, sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
|
||||
]
|
||||
smid2ArchiveTable (smid,cid) = DBTable
|
||||
{ dbtSQLQuery = submissionFileQuery smid
|
||||
@ -254,6 +254,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
, SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified
|
||||
)
|
||||
]
|
||||
, dbtFilter = []
|
||||
}
|
||||
mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
|
||||
|
||||
|
||||
@ -31,10 +31,10 @@ getTermShowR = do
|
||||
-- return term
|
||||
--
|
||||
let
|
||||
termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64))
|
||||
termData term = do
|
||||
-- E.orderBy [E.desc $ term E.^. TermStart ]
|
||||
let courseCount :: E.SqlExpr (E.Value Int)
|
||||
courseCount = E.sub_select . E.from $ \course -> do
|
||||
let courseCount = E.sub_select . E.from $ \course -> do
|
||||
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
|
||||
return E.countRows
|
||||
return (term, courseCount)
|
||||
@ -42,7 +42,7 @@ getTermShowR = do
|
||||
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
|
||||
provideRep $ do
|
||||
let colonnadeTerms = mconcat
|
||||
[ sortable Nothing "Kürzel" $ \(_, (Entity tid Term{..},_)) -> cell $ do
|
||||
[ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
|
||||
-- Scrap this if to slow, create term edit page instead
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
|
||||
[whamlet|
|
||||
@ -52,22 +52,20 @@ getTermShowR = do
|
||||
$else
|
||||
#{termToText termName}
|
||||
|]
|
||||
, sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(_, (Entity _ Term{..},_)) ->
|
||||
, sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termLectureStart
|
||||
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(_, (Entity _ Term{..},_)) ->
|
||||
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termLectureEnd
|
||||
, sortable Nothing "Aktiv" $ \(_, (Entity _ Term{..},_)) ->
|
||||
, sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
|
||||
textCell $ bool "" tickmark termActive
|
||||
, sortable Nothing "Kursliste" $ \(_, (Entity tid Term{..}, E.Value numCourses)) ->
|
||||
cell [whamlet|
|
||||
<a href=@{TermCourseListR tid}>
|
||||
#{show numCourses} Kurse
|
||||
|]
|
||||
, sortable (Just "start") "Semesteranfang" $ \(_, (Entity _ Term{..},_)) ->
|
||||
, sortable Nothing "Kursliste" $ anchorCell
|
||||
(\(Entity tid _, _) -> TermCourseListR tid)
|
||||
(\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|])
|
||||
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termStart
|
||||
, sortable (Just "end") "Semesterende" $ \(_, (Entity _ Term{..},_)) ->
|
||||
, sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termEnd
|
||||
, sortable Nothing "Feiertage im Semester" $ \(_, (Entity _ Term{..},_)) ->
|
||||
, sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
|
||||
]
|
||||
table <- dbTable def $ DBTable
|
||||
@ -86,6 +84,10 @@ getTermShowR = do
|
||||
, SortColumn $ \term -> term E.^. TermLectureEnd
|
||||
)
|
||||
]
|
||||
, dbtFilter = [ ( "active"
|
||||
, FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
|
||||
)
|
||||
]
|
||||
, dbtAttrs = tableDefault
|
||||
, dbtIdent = "terms" :: Text
|
||||
}
|
||||
|
||||
@ -7,10 +7,15 @@
|
||||
, LambdaCase
|
||||
, ViewPatterns
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, MultiParamTypeClasses
|
||||
, TypeFamilies
|
||||
#-}
|
||||
|
||||
module Handler.Utils.Table.Pagination
|
||||
( SortColumn(..), SortDirection(..)
|
||||
, FilterColumn(..), IsFilterColumn
|
||||
, DBRow(..), DBOutput
|
||||
, DBTable(..)
|
||||
, PaginationSettings(..)
|
||||
, PSValidator(..)
|
||||
@ -36,11 +41,14 @@ import qualified Network.Wai as Wai
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_)
|
||||
import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
|
||||
|
||||
import Data.Map (Map, (!))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Colonnade hiding (bool, fromMaybe)
|
||||
import Data.Profunctor (lmap)
|
||||
|
||||
import Colonnade hiding (bool, fromMaybe, singleton)
|
||||
import Colonnade.Encode
|
||||
import Yesod.Colonnade
|
||||
|
||||
@ -64,22 +72,65 @@ instance PathPiece SortDirection where
|
||||
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
|
||||
sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t
|
||||
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
|
||||
|
||||
data DBTable = forall a r h i t.
|
||||
( ToSortable h
|
||||
, E.SqlSelect a r
|
||||
|
||||
|
||||
data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
|
||||
|
||||
filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
|
||||
filterColumn (FilterColumn f) = filterColumn' f
|
||||
|
||||
class IsFilterColumn t a where
|
||||
filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
|
||||
|
||||
instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where
|
||||
filterColumn' fin _ _ = fin
|
||||
|
||||
instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
|
||||
filterColumn' cont is t = filterColumn' (cont t) is t
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
|
||||
filterColumn' cont is t = filterColumn' (cont input) is' t
|
||||
where
|
||||
(input, ($ []) -> is') = go (mempty, id) is
|
||||
go acc [] = acc
|
||||
go (acc, is') (i:is)
|
||||
| Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
|
||||
| otherwise = go (acc, is' . (i:)) is
|
||||
|
||||
|
||||
data DBRow r = DBRow
|
||||
{ dbrIndex, dbrCount :: Int64
|
||||
, dbrOutput :: r
|
||||
}
|
||||
|
||||
class DBOutput r r' where
|
||||
dbProj :: r -> r'
|
||||
|
||||
instance DBOutput r r where
|
||||
dbProj = id
|
||||
instance DBOutput (DBRow r) r where
|
||||
dbProj = dbrOutput
|
||||
instance DBOutput (DBRow r) (Int64, r) where
|
||||
dbProj = (,) <$> dbrIndex <*> dbrOutput
|
||||
|
||||
|
||||
data DBTable = forall a r r' h i t.
|
||||
( ToSortable h, Functor h
|
||||
, E.SqlSelect a r, DBOutput (DBRow r) r'
|
||||
, PathPiece i
|
||||
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
|
||||
) => DBTable
|
||||
{ dbtSQLQuery :: t -> E.SqlQuery a
|
||||
, dbtColonnade :: Colonnade h (Int64, r) (Cell UniWorX)
|
||||
, dbtColonnade :: Colonnade h r' (Cell UniWorX)
|
||||
, dbtSorting :: Map Text (SortColumn t)
|
||||
, dbtFilter :: Map Text (FilterColumn t)
|
||||
, dbtAttrs :: Attribute
|
||||
, dbtIdent :: i
|
||||
}
|
||||
|
||||
data PaginationSettings = PaginationSettings
|
||||
{ psSorting :: [(Text, SortDirection)]
|
||||
, psFilter :: Map Text [Text]
|
||||
, psLimit :: Int64
|
||||
, psPage :: Int64
|
||||
, psShortcircuit :: Bool
|
||||
@ -88,15 +139,16 @@ data PaginationSettings = PaginationSettings
|
||||
instance Default PaginationSettings where
|
||||
def = PaginationSettings
|
||||
{ psSorting = []
|
||||
, psFilter = Map.empty
|
||||
, psLimit = 50
|
||||
, psPage = 0
|
||||
, psShortcircuit = False
|
||||
}
|
||||
|
||||
newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
|
||||
newtype PSValidator = PSValidator { runPSValidator :: DBTable -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
|
||||
|
||||
instance Default PSValidator where
|
||||
def = PSValidator $ \case
|
||||
def = PSValidator $ \DBTable{..} -> \case
|
||||
Nothing -> def
|
||||
Just ps -> swap . (\act -> execRWS act () ps) $ do
|
||||
l <- gets psLimit
|
||||
@ -106,7 +158,7 @@ instance Default PSValidator where
|
||||
|
||||
|
||||
dbTable :: PSValidator -> DBTable -> Handler Widget
|
||||
dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
|
||||
dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do
|
||||
let
|
||||
sortingOptions = mkOptionList
|
||||
[ Option t' (t, d) t'
|
||||
@ -114,35 +166,43 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
|
||||
, d <- [SortAsc, SortDesc]
|
||||
, let t' = t <> "-" <> toPathPiece d
|
||||
]
|
||||
(_, defPS) = runPSValidator Nothing
|
||||
(_, defPS) = runPSValidator dbtable Nothing
|
||||
wIdent n
|
||||
| not $ null dbtIdent = dbtIdent <> "-" <> n
|
||||
| otherwise = n
|
||||
dbtAttrs'
|
||||
| not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs
|
||||
| otherwise = dbtAttrs
|
||||
multiTextField = Field
|
||||
{ fieldParse = \ts _ -> return . Right $ Just ts
|
||||
, fieldView = undefined
|
||||
, fieldEnctype = UrlEncoded
|
||||
}
|
||||
|
||||
psResult <- runInputGetResult $ PaginationSettings
|
||||
<$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting"))
|
||||
<*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField (wIdent $ "filter." <> k)) dbtFilter)
|
||||
<*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
|
||||
<*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page"))
|
||||
<*> ireq checkBoxField (wIdent "table-only")
|
||||
|
||||
$(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult)
|
||||
<*> (psLimit <$> psResult)
|
||||
<*> (psPage <$> psResult)
|
||||
<*> (psShortcircuit <$> psResult)
|
||||
$(logDebug) . tshow $ (,,,,) <$> (length . psSorting <$> psResult)
|
||||
<*> (Map.keys . psFilter <$> psResult)
|
||||
<*> (psLimit <$> psResult)
|
||||
<*> (psPage <$> psResult)
|
||||
<*> (psShortcircuit <$> psResult)
|
||||
|
||||
let
|
||||
(errs, PaginationSettings{..}) = case psResult of
|
||||
FormSuccess ps -> runPSValidator $ Just ps
|
||||
FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing
|
||||
FormMissing -> runPSValidator Nothing
|
||||
FormSuccess ps -> runPSValidator dbtable $ Just ps
|
||||
FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing
|
||||
FormMissing -> runPSValidator dbtable Nothing
|
||||
psSorting' = map (first (dbtSorting !)) psSorting
|
||||
sqlQuery' = E.from $ \t -> dbtSQLQuery t
|
||||
<* E.orderBy (map (sqlSortDirection t) psSorting')
|
||||
<* E.limit psLimit
|
||||
<* E.offset (psPage * psLimit)
|
||||
<* E.where_ (Map.foldrWithKey (\key args expr -> filterColumn (dbtFilter ! key) args t E.&&. expr) (E.val True) psFilter)
|
||||
|
||||
mapM_ (addMessageI "warning") errs
|
||||
|
||||
@ -152,7 +212,7 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
|
||||
rowCount
|
||||
| ((_, E.Value n), _):_ <- rows' = n
|
||||
| otherwise = 0
|
||||
rows = map (\((E.Value i, _), r) -> (i, r)) rows'
|
||||
rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows'
|
||||
|
||||
bool return (sendResponse <=< tblLayout) psShortcircuit $ do
|
||||
getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
||||
|
||||
@ -12,7 +12,7 @@ import Colonnade
|
||||
import Colonnade.Encode
|
||||
|
||||
data Sortable a = Sortable
|
||||
{ sortableKey :: (Maybe Text)
|
||||
{ sortableKey :: Maybe Text
|
||||
, sortableContent :: a
|
||||
}
|
||||
|
||||
@ -23,6 +23,9 @@ instance Headedness Sortable where
|
||||
headednessPure = Sortable Nothing
|
||||
headednessExtract = Just $ \(Sortable _ x) -> x
|
||||
headednessExtractForall = Just $ ExtractForall (\(Sortable _ x) -> x)
|
||||
|
||||
instance Functor Sortable where
|
||||
fmap f Sortable{..} = Sortable { sortableContent = f sortableContent, .. }
|
||||
|
||||
newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user