From b96411460c7dda3b495d0cea0f1083e7d8bc496c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 16 Mar 2018 10:25:55 +0100 Subject: [PATCH 1/5] Start work on server side pagination --- src/Handler/Utils/Table/Pagination.hs | 96 +++++++++++++++++++++++++++ templates/table-layout.hamlet | 1 + 2 files changed, 97 insertions(+) create mode 100644 src/Handler/Utils/Table/Pagination.hs create mode 100644 templates/table-layout.hamlet diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs new file mode 100644 index 000000000..c23b716a7 --- /dev/null +++ b/src/Handler/Utils/Table/Pagination.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , RecordWildCards + , OverloadedStrings + , TemplateHaskell + #-} + +module Handler.Utils.Table.Pagination where + +import Import +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) +import Text.Blaze (Attribute) + +import Data.Map (Map) + +import Colonnade hiding (bool) +import Yesod.Colonnade + +import Text.Hamlet (hamletFile) + + +data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) } +data SortDirection = SortAsc | SortDesc + deriving (Eq, Ord, Enum, Show, Read) + +sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy +sqlSortDirection (SortColumn e, SortAsc ) = E.asc e +sqlSortDirection (SortColumn e, SortDesc) = E.desc e + +data DBTable = forall a r h. + ( Headedness h + , E.SqlSelect a r + ) => DBTable + { dbtSQLQuery :: E.SqlQuery a + , dbtColonnade :: Colonnade h r (Cell UniWorX) + , dbtSorting :: Map Text SortColumn + , dbtAttrs :: Attribute + } + +data PaginationSettings = PaginationSettings + { psSorting :: [(SortColumn, SortDirection)] + , psLimit :: Int64 + , psPage :: Int64 + , psShortcircuit :: Bool + } + +instance Default PaginationSettings where + def = PaginationSettings + { psSorting = [] + , psLimit = 50 + , psPage = 0 + , psShortcircuit = False + } + +dbTable :: PaginationSettings -> DBTable -> Handler Widget +dbTable defPS DBTable{..} = do + let + sortingOptions = mkOptionList + [ Option t' (c, d) t' + | (t, c) <- mapToList dbtSorting + , d <- [SortAsc, SortDesc] + , let t' = t <> "-" <> tshow d + ] + sortingField = Field parse (\_ _ _ _ _ -> return ()) UrlEncoded + where + parse optlist _ = case mapM (olReadExternal sortingOptions) optlist of + Nothing -> return $ Left "Error parsing values" + Just res -> return $ Right $ Just res + psResult <- runInputGetResult $ PaginationSettings + <$> ireq sortingField "sorting" + <*> ireq intField "pagesize" + <*> ireq intField "page" + <*> ireq checkBoxField "table-only" + + $(logDebug) $ tshow (length . psSorting <$> psResult, psLimit <$> psResult, psPage <$> psResult, psShortcircuit <$> psResult) + + PaginationSettings{..} <- case psResult of + (FormSuccess ps) -> return ps + -- (FormSuccess ps) -> case dbtValidatePS ps of + -- Right ps' -> return ps' + -- Left errs -> defPS <$ mapM_ (addMessageI "error") errs + _ -> return defPS + + let sqlQuery' = dbtSQLQuery + <* E.orderBy (map sqlSortDirection psSorting) + <* E.limit psLimit + <* E.offset (psPage * psLimit) + + rows <- runDB $ E.select sqlQuery' + + bool return (sendResponse <=< tblLayout) psShortcircuit $ do + encodeCellTable dbtAttrs dbtColonnade rows + where + tblLayout :: Widget -> Handler Html + tblLayout = widgetToPageContent >=> (\tbl -> withUrlRenderer $(hamletFile "templates/table-layout.hamlet")) diff --git a/templates/table-layout.hamlet b/templates/table-layout.hamlet new file mode 100644 index 000000000..34b53ce1f --- /dev/null +++ b/templates/table-layout.hamlet @@ -0,0 +1 @@ +^{pageBody tbl} From a0ccae13b79e0af30b190e31a095cac80a23c78f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 16 Mar 2018 10:28:43 +0100 Subject: [PATCH 2/5] Intigrate pagination into term list --- src/Handler/Term.hs | 43 +++++++++++++++++++++++++------------------ src/Handler/Utils.hs | 1 + 2 files changed, 26 insertions(+), 18 deletions(-) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 38eaea847..f33fde929 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -28,18 +28,19 @@ getTermShowR = do -- E.orderBy [E.desc $ term E.^. TermStart ] -- return term -- - termData <- runDB $ E.select . E.from $ \term -> do - E.orderBy [E.desc $ term E.^. TermStart ] - let courseCount :: E.SqlExpr (E.Value Int) - courseCount = E.sub_select . E.from $ \course -> do - E.where_ $ term E.^. TermId E.==. course E.^. CourseTermId - return E.countRows - return (term, courseCount) + let + termData = E.from $ \term -> do + E.orderBy [E.desc $ term E.^. TermStart ] + let courseCount :: E.SqlExpr (E.Value Int) + courseCount = E.sub_select . E.from $ \course -> do + E.where_ $ term E.^. TermId E.==. course E.^. CourseTermId + return E.countRows + return (term, courseCount) selectRep $ do - provideRep $ return $ toJSON $ map fst termData + provideRep $ toJSON . map fst <$> runDB (E.select termData) provideRep $ do let colonnadeTerms = mconcat - [ headed "Kürzel" $ \(Entity tid Term{..},_) -> do + [ headed "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do -- Scrap this if to slow, create term edit page instead adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False [whamlet| @@ -50,26 +51,32 @@ getTermShowR = do #{termToText termName} |] , headed "Beginn Vorlesungen" $ \(Entity _ Term{..},_) -> - fromString $ formatTimeGerWD termLectureStart + stringCell $ formatTimeGerWD termLectureStart , headed "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> - fromString $ formatTimeGerWD termLectureEnd + stringCell $ formatTimeGerWD termLectureEnd , headed "Aktiv" $ \(Entity _ Term{..},_) -> - bool "" tickmark termActive + textCell $ bool "" tickmark termActive , headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) -> - [whamlet| + cell [whamlet| #{show numCourses} Kurse |] , headed "Semesteranfang" $ \(Entity _ Term{..},_) -> - fromString $ formatTimeGerWD termStart + stringCell $ formatTimeGerWD termStart , headed "Semesterende" $ \(Entity _ Term{..},_) -> - fromString $ formatTimeGerWD termEnd + stringCell $ formatTimeGerWD termEnd , headed "Feiertage im Semester" $ \(Entity _ Term{..},_) -> - fromString $ (intercalate ", ") $ map formatTimeGerWD termHolidays + stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays ] + table <- dbTable def $ DBTable + { dbtSQLQuery = termData + , dbtColonnade = colonnadeTerms + , dbtSorting = mempty + , dbtAttrs = tableDefault + } defaultLayout $ do - setTitle "Freigeschaltete Semester" - encodeWidgetTable tableDefault colonnadeTerms termData + setTitle "Freigeschaltete Semester" + table getTermEditR :: Handler Html diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index e8143d998..30b3fb73e 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -13,6 +13,7 @@ import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.Term as Handler.Utils import Handler.Utils.Form as Handler.Utils import Handler.Utils.Table as Handler.Utils +import Handler.Utils.Table.Pagination as Handler.Utils import Handler.Utils.Zip as Handler.Utils import Handler.Utils.Rating as Handler.Utils From 96cdef253845f7247deaef1faa0691997ae0bbdb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 16 Mar 2018 12:54:18 +0100 Subject: [PATCH 3/5] Better PSValidator --- messages/de.msg | 3 +- src/Handler/Utils/Table/Pagination.hs | 53 ++++++++++++++++++--------- 2 files changed, 38 insertions(+), 18 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index b23e13c99..0f6ec28bb 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -1,2 +1,3 @@ SummerTerm year@Integer: Sommersemester #{tshow year} -WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year} \ No newline at end of file +WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year} +PSLimitNonPositive: “pagesize” muss größer als null sein \ No newline at end of file diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c23b716a7..c564111d3 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -3,6 +3,7 @@ , RecordWildCards , OverloadedStrings , TemplateHaskell + , LambdaCase #-} module Handler.Utils.Table.Pagination where @@ -12,9 +13,11 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) import Text.Blaze (Attribute) +import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_) + import Data.Map (Map) -import Colonnade hiding (bool) +import Colonnade hiding (bool, fromMaybe) import Yesod.Colonnade import Text.Hamlet (hamletFile) @@ -53,8 +56,19 @@ instance Default PaginationSettings where , psShortcircuit = False } -dbTable :: PaginationSettings -> DBTable -> Handler Widget -dbTable defPS DBTable{..} = do +newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) } + +instance Default PSValidator where + def = PSValidator $ \case + Nothing -> def + Just ps -> swap . (\act -> execRWS act () ps) $ do + l <- gets psLimit + when (l <= 0) $ do + modify $ \ps -> ps { psLimit = psLimit def } + tell . pure $ SomeMessage MsgPSLimitNonPositive + +dbTable :: PSValidator -> DBTable -> Handler Widget +dbTable PSValidator{..} DBTable{..} = do let sortingOptions = mkOptionList [ Option t' (c, d) t' @@ -67,25 +81,30 @@ dbTable defPS DBTable{..} = do parse optlist _ = case mapM (olReadExternal sortingOptions) optlist of Nothing -> return $ Left "Error parsing values" Just res -> return $ Right $ Just res + (_, defPS) = runPSValidator Nothing + psResult <- runInputGetResult $ PaginationSettings <$> ireq sortingField "sorting" - <*> ireq intField "pagesize" - <*> ireq intField "page" + <*> (fromMaybe (psLimit defPS) <$> iopt intField "pagesize") + <*> (fromMaybe (psPage defPS) <$> iopt intField "page") <*> ireq checkBoxField "table-only" - $(logDebug) $ tshow (length . psSorting <$> psResult, psLimit <$> psResult, psPage <$> psResult, psShortcircuit <$> psResult) + $(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult) + <*> (psLimit <$> psResult) + <*> (psPage <$> psResult) + <*> (psShortcircuit <$> psResult) - PaginationSettings{..} <- case psResult of - (FormSuccess ps) -> return ps - -- (FormSuccess ps) -> case dbtValidatePS ps of - -- Right ps' -> return ps' - -- Left errs -> defPS <$ mapM_ (addMessageI "error") errs - _ -> return defPS - - let sqlQuery' = dbtSQLQuery - <* E.orderBy (map sqlSortDirection psSorting) - <* E.limit psLimit - <* E.offset (psPage * psLimit) + let + (errs, PaginationSettings{..}) = case psResult of + FormSuccess ps -> runPSValidator $ Just ps + FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing + FormMissing -> runPSValidator Nothing + sqlQuery' = dbtSQLQuery + <* E.orderBy (map sqlSortDirection psSorting) + <* E.limit psLimit + <* E.offset (psPage * psLimit) + + mapM_ (addMessageI "warning") errs rows <- runDB $ E.select sqlQuery' From d47fa717a32bcfbc62ba647e36a2b5f06aa01de7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 16 Mar 2018 12:58:49 +0100 Subject: [PATCH 4/5] Identify tables --- src/Handler/Term.hs | 1 + src/Handler/Utils/Table/Pagination.hs | 13 ++++++++----- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index f33fde929..60776bbef 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -73,6 +73,7 @@ getTermShowR = do , dbtColonnade = colonnadeTerms , dbtSorting = mempty , dbtAttrs = tableDefault + , dbtIdent = "terms" :: Text } defaultLayout $ do setTitle "Freigeschaltete Semester" diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c564111d3..cbe39921b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -31,14 +31,16 @@ sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy sqlSortDirection (SortColumn e, SortAsc ) = E.asc e sqlSortDirection (SortColumn e, SortDesc) = E.desc e -data DBTable = forall a r h. +data DBTable = forall a r h i. ( Headedness h , E.SqlSelect a r + , PathPiece i ) => DBTable { dbtSQLQuery :: E.SqlQuery a , dbtColonnade :: Colonnade h r (Cell UniWorX) , dbtSorting :: Map Text SortColumn , dbtAttrs :: Attribute + , dbtIdent :: i } data PaginationSettings = PaginationSettings @@ -82,12 +84,13 @@ dbTable PSValidator{..} DBTable{..} = do Nothing -> return $ Left "Error parsing values" Just res -> return $ Right $ Just res (_, defPS) = runPSValidator Nothing + wIdent n = toPathPiece dbtIdent <> "-" <> n psResult <- runInputGetResult $ PaginationSettings - <$> ireq sortingField "sorting" - <*> (fromMaybe (psLimit defPS) <$> iopt intField "pagesize") - <*> (fromMaybe (psPage defPS) <$> iopt intField "page") - <*> ireq checkBoxField "table-only" + <$> ireq sortingField (wIdent "sorting") + <*> (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) From 907958baf440631b1847b64d2f477543b0f813b4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 16 Mar 2018 13:06:52 +0100 Subject: [PATCH 5/5] Cleanup identified tables --- src/Handler/Utils/Table/Pagination.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index cbe39921b..428810362 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -4,6 +4,7 @@ , OverloadedStrings , TemplateHaskell , LambdaCase + , ViewPatterns #-} module Handler.Utils.Table.Pagination where @@ -70,7 +71,7 @@ instance Default PSValidator where tell . pure $ SomeMessage MsgPSLimitNonPositive dbTable :: PSValidator -> DBTable -> Handler Widget -dbTable PSValidator{..} DBTable{..} = do +dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do let sortingOptions = mkOptionList [ Option t' (c, d) t' @@ -84,7 +85,9 @@ dbTable PSValidator{..} DBTable{..} = do Nothing -> return $ Left "Error parsing values" Just res -> return $ Right $ Just res (_, defPS) = runPSValidator Nothing - wIdent n = toPathPiece dbtIdent <> "-" <> n + wIdent n + | not $ null dbtIdent = dbtIdent <> "-" <> n + | otherwise = n psResult <- runInputGetResult $ PaginationSettings <$> ireq sortingField (wIdent "sorting")