From 276881957ea43171e03d332d4947d50f10d51745 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 7 Jun 2018 15:01:53 +0200 Subject: [PATCH] Support for dbTable filters --- messages/de.msg | 2 + src/Handler/Sheet.hs | 9 +- src/Handler/Submission.hs | 7 +- src/Handler/Term.hs | 30 ++++--- src/Handler/Utils/Table/Pagination.hs | 98 +++++++++++++++++---- src/Handler/Utils/Table/Pagination/Types.hs | 5 +- 6 files changed, 110 insertions(+), 41 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index d5403dc7f..1248d699f 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -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 \ No newline at end of file diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 1defbcce5..0776f2ceb 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 528e9b966..3d738fe32 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 95ea678f4..a6942d85f 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -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| - - #{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 } diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index b1f1bcb58..0625975b2 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index c2038c4d0..1c0c883d6 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -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}