fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'feat/pagination'

Browse Source
This commit is contained in:
Gregor Kleen 2018-06-07 15:02:34 +02:00
commit d5f773317f
6 changed files with 110 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/de.msg
View File

@ -51,3 +51,5 @@ NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs
HomeHeading: Startseite HomeHeading: Startseite
TermsHeading: Semesterübersicht TermsHeading: Semesterübersicht
NumCourses n@Int64: #{tshow n} Kurse

9
src/Handler/Sheet.hs
View File

@ -8,6 +8,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
module Handler.Sheet where module Handler.Sheet where
@ -209,10 +210,10 @@ getSShowR tid csh shn = do
-- return desired columns -- return desired columns
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = mconcat let colonnadeFiles = mconcat
[ sortable (Just "type") "Typ" $ \(_, (_,_, E.Value ftype)) -> textCell $ toPathPiece ftype [ 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)) , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
(\(_, (E.Value fName,_,_)) -> str2widget fName) (\(E.Value fName,_,_) -> str2widget fName)
, sortable (Just "time") "Modifikation" $ \(_, (_,E.Value modified,_)) -> stringCell $ formatTimeGerWDT modified , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
] ]
fileTable <- dbTable def $ DBTable fileTable <- dbTable def $ DBTable
{ dbtSQLQuery = fileData { dbtSQLQuery = fileData

7
src/Handler/Submission.hs
View File

@ -238,9 +238,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
-- Maybe construct a table to display uploaded archive files -- Maybe construct a table to display uploaded archive files
let colonnadeFiles cid = mconcat let colonnadeFiles cid = mconcat
-- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
[ sortable (Just "path") "Dateiname" $ anchorCell (\(_, (Entity _ File{..})) -> SubmissionDownloadSingleR cid fileTitle) [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle)
(\(_, (Entity _ File{..})) -> str2widget fileTitle) (\(Entity _ File{..}) -> str2widget fileTitle)
, sortable (Just "time") "Modifikation" $ \(_, (Entity _ File{..})) -> stringCell $ formatTimeGerWDT fileModified , sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
] ]
smid2ArchiveTable (smid,cid) = DBTable smid2ArchiveTable (smid,cid) = DBTable
{ dbtSQLQuery = submissionFileQuery smid { dbtSQLQuery = submissionFileQuery smid
@ -254,6 +254,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
, SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified
) )
] ]
, dbtFilter = []
} }
mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid

30
src/Handler/Term.hs
View File

@ -31,10 +31,10 @@ getTermShowR = do
-- return term -- return term
-- --
let let
termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64))
termData term = do termData term = do
-- E.orderBy [E.desc $ term E.^. TermStart ] -- E.orderBy [E.desc $ term E.^. TermStart ]
let courseCount :: E.SqlExpr (E.Value Int) let courseCount = E.sub_select . E.from $ \course -> do
courseCount = E.sub_select . E.from $ \course -> do
E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
return E.countRows return E.countRows
return (term, courseCount) return (term, courseCount)
@ -42,7 +42,7 @@ getTermShowR = do
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
provideRep $ do provideRep $ do
let colonnadeTerms = mconcat 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 -- Scrap this if to slow, create term edit page instead
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
[whamlet| [whamlet|
@ -52,22 +52,20 @@ getTermShowR = do
$else $else
#{termToText termName} #{termToText termName}
|] |]
, sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(_, (Entity _ Term{..},_)) -> , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
stringCell $ formatTimeGerWD termLectureStart stringCell $ formatTimeGerWD termLectureStart
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(_, (Entity _ Term{..},_)) -> , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
stringCell $ formatTimeGerWD termLectureEnd stringCell $ formatTimeGerWD termLectureEnd
, sortable Nothing "Aktiv" $ \(_, (Entity _ Term{..},_)) -> , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
textCell $ bool "" tickmark termActive textCell $ bool "" tickmark termActive
, sortable Nothing "Kursliste" $ \(_, (Entity tid Term{..}, E.Value numCourses)) -> , sortable Nothing "Kursliste" $ anchorCell
cell [whamlet| (\(Entity tid _, _) -> TermCourseListR tid)
<a href=@{TermCourseListR tid}> (\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|])
#{show numCourses} Kurse , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
|]
, sortable (Just "start") "Semesteranfang" $ \(_, (Entity _ Term{..},_)) ->
stringCell $ formatTimeGerWD termStart stringCell $ formatTimeGerWD termStart
, sortable (Just "end") "Semesterende" $ \(_, (Entity _ Term{..},_)) -> , sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) ->
stringCell $ formatTimeGerWD termEnd stringCell $ formatTimeGerWD termEnd
, sortable Nothing "Feiertage im Semester" $ \(_, (Entity _ Term{..},_)) -> , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
] ]
table <- dbTable def $ DBTable table <- dbTable def $ DBTable
@ -86,6 +84,10 @@ getTermShowR = do
, SortColumn $ \term -> term E.^. TermLectureEnd , SortColumn $ \term -> term E.^. TermLectureEnd
) )
] ]
, dbtFilter = [ ( "active"
, FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
)
]
, dbtAttrs = tableDefault , dbtAttrs = tableDefault
, dbtIdent = "terms" :: Text , dbtIdent = "terms" :: Text
} }

96
src/Handler/Utils/Table/Pagination.hs
View File

@ -7,10 +7,15 @@
, LambdaCase , LambdaCase
, ViewPatterns , ViewPatterns
, FlexibleContexts , FlexibleContexts
, FlexibleInstances
, MultiParamTypeClasses
, TypeFamilies
#-} #-}
module Handler.Utils.Table.Pagination module Handler.Utils.Table.Pagination
( SortColumn(..), SortDirection(..) ( SortColumn(..), SortDirection(..)
, FilterColumn(..), IsFilterColumn
, DBRow(..), DBOutput
, DBTable(..) , DBTable(..)
, PaginationSettings(..) , PaginationSettings(..)
, PSValidator(..) , PSValidator(..)
@ -36,11 +41,14 @@ import qualified Network.Wai as Wai
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as 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 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 Colonnade.Encode
import Yesod.Colonnade import Yesod.Colonnade
@ -65,21 +73,64 @@ sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
data DBTable = forall a r h i t.
( ToSortable h data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
, E.SqlSelect a r
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 , PathPiece i
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
) => DBTable ) => DBTable
{ dbtSQLQuery :: t -> E.SqlQuery a { dbtSQLQuery :: t -> E.SqlQuery a
, dbtColonnade :: Colonnade h (Int64, r) (Cell UniWorX) , dbtColonnade :: Colonnade h r' (Cell UniWorX)
, dbtSorting :: Map Text (SortColumn t) , dbtSorting :: Map Text (SortColumn t)
, dbtFilter :: Map Text (FilterColumn t)
, dbtAttrs :: Attribute , dbtAttrs :: Attribute
, dbtIdent :: i , dbtIdent :: i
} }
data PaginationSettings = PaginationSettings data PaginationSettings = PaginationSettings
{ psSorting :: [(Text, SortDirection)] { psSorting :: [(Text, SortDirection)]
, psFilter :: Map Text [Text]
, psLimit :: Int64 , psLimit :: Int64
, psPage :: Int64 , psPage :: Int64
, psShortcircuit :: Bool , psShortcircuit :: Bool
@ -88,15 +139,16 @@ data PaginationSettings = PaginationSettings
instance Default PaginationSettings where instance Default PaginationSettings where
def = PaginationSettings def = PaginationSettings
{ psSorting = [] { psSorting = []
, psFilter = Map.empty
, psLimit = 50 , psLimit = 50
, psPage = 0 , psPage = 0
, psShortcircuit = False , 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 instance Default PSValidator where
def = PSValidator $ \case def = PSValidator $ \DBTable{..} -> \case
Nothing -> def Nothing -> def
Just ps -> swap . (\act -> execRWS act () ps) $ do Just ps -> swap . (\act -> execRWS act () ps) $ do
l <- gets psLimit l <- gets psLimit
@ -106,7 +158,7 @@ instance Default PSValidator where
dbTable :: PSValidator -> DBTable -> Handler Widget 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 let
sortingOptions = mkOptionList sortingOptions = mkOptionList
[ Option t' (t, d) t' [ Option t' (t, d) t'
@ -114,35 +166,43 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
, d <- [SortAsc, SortDesc] , d <- [SortAsc, SortDesc]
, let t' = t <> "-" <> toPathPiece d , let t' = t <> "-" <> toPathPiece d
] ]
(_, defPS) = runPSValidator Nothing (_, defPS) = runPSValidator dbtable Nothing
wIdent n wIdent n
| not $ null dbtIdent = dbtIdent <> "-" <> n | not $ null dbtIdent = dbtIdent <> "-" <> n
| otherwise = n | otherwise = n
dbtAttrs' dbtAttrs'
| not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs
| otherwise = dbtAttrs | otherwise = dbtAttrs
multiTextField = Field
{ fieldParse = \ts _ -> return . Right $ Just ts
, fieldView = undefined
, fieldEnctype = UrlEncoded
}
psResult <- runInputGetResult $ PaginationSettings psResult <- runInputGetResult $ PaginationSettings
<$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")) <$> (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 (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
<*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page"))
<*> ireq checkBoxField (wIdent "table-only") <*> ireq checkBoxField (wIdent "table-only")
$(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult) $(logDebug) . tshow $ (,,,,) <$> (length . psSorting <$> psResult)
<*> (psLimit <$> psResult) <*> (Map.keys . psFilter <$> psResult)
<*> (psPage <$> psResult) <*> (psLimit <$> psResult)
<*> (psShortcircuit <$> psResult) <*> (psPage <$> psResult)
<*> (psShortcircuit <$> psResult)
let let
(errs, PaginationSettings{..}) = case psResult of (errs, PaginationSettings{..}) = case psResult of
FormSuccess ps -> runPSValidator $ Just ps FormSuccess ps -> runPSValidator dbtable $ Just ps
FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing
FormMissing -> runPSValidator Nothing FormMissing -> runPSValidator dbtable Nothing
psSorting' = map (first (dbtSorting !)) psSorting psSorting' = map (first (dbtSorting !)) psSorting
sqlQuery' = E.from $ \t -> dbtSQLQuery t sqlQuery' = E.from $ \t -> dbtSQLQuery t
<* E.orderBy (map (sqlSortDirection t) psSorting') <* E.orderBy (map (sqlSortDirection t) psSorting')
<* E.limit psLimit <* E.limit psLimit
<* E.offset (psPage * 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 mapM_ (addMessageI "warning") errs
@ -152,7 +212,7 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
rowCount rowCount
| ((_, E.Value n), _):_ <- rows' = n | ((_, E.Value n), _):_ <- rows' = n
| otherwise = 0 | 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 bool return (sendResponse <=< tblLayout) psShortcircuit $ do
getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest

5
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -12,7 +12,7 @@ import Colonnade
import Colonnade.Encode import Colonnade.Encode
data Sortable a = Sortable data Sortable a = Sortable
{ sortableKey :: (Maybe Text) { sortableKey :: Maybe Text
, sortableContent :: a , sortableContent :: a
} }
@ -24,6 +24,9 @@ instance Headedness Sortable where
headednessExtract = Just $ \(Sortable _ x) -> x headednessExtract = Just $ \(Sortable _ x) -> x
headednessExtractForall = Just $ ExtractForall (\(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} newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a}
class Headedness s => ToSortable s where class Headedness s => ToSortable s where