From ba918129c9e288cae2da3e837cc2286128973c84 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 16 Mar 2018 13:30:58 +0100 Subject: [PATCH 1/5] Identify paginated table with html-id --- src/Handler/Utils/Table/Pagination.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 428810362..2f67bf522 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -13,6 +13,7 @@ import Import import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) import Text.Blaze (Attribute) +import qualified Text.Blaze.Html5.Attributes as Html5 import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_) @@ -88,6 +89,9 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do wIdent n | not $ null dbtIdent = dbtIdent <> "-" <> n | otherwise = n + dbtAttrs' + | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs + | otherwise = dbtAttrs psResult <- runInputGetResult $ PaginationSettings <$> ireq sortingField (wIdent "sorting") @@ -115,7 +119,7 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do rows <- runDB $ E.select sqlQuery' bool return (sendResponse <=< tblLayout) psShortcircuit $ do - encodeCellTable dbtAttrs dbtColonnade rows + encodeCellTable dbtAttrs' dbtColonnade rows where tblLayout :: Widget -> Handler Html tblLayout = widgetToPageContent >=> (\tbl -> withUrlRenderer $(hamletFile "templates/table-layout.hamlet")) From 2cfd87de87835a9bdfbc4f18e6da49e58d1fb89e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 16 Mar 2018 14:09:12 +0100 Subject: [PATCH 2/5] Page indicator --- messages/de.msg | 3 ++- src/Handler/Term.hs | 2 +- src/Handler/Utils/Table/Pagination.hs | 10 +++++++--- templates/table-layout-wrapper.hamlet | 1 + templates/table-layout.hamlet | 5 ++++- 5 files changed, 15 insertions(+), 6 deletions(-) create mode 100644 templates/table-layout-wrapper.hamlet diff --git a/messages/de.msg b/messages/de.msg index 0f6ec28bb..710f73cae 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -1,3 +1,4 @@ SummerTerm year@Integer: Sommersemester #{tshow year} WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year} -PSLimitNonPositive: “pagesize” muss größer als null sein \ No newline at end of file +PSLimitNonPositive: “pagesize” muss größer als null sein +Page n@Int64 num@Int64: Seite #{tshow n} von #{tshow num} \ No newline at end of file diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 60776bbef..0ec926787 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -30,7 +30,7 @@ getTermShowR = do -- let termData = E.from $ \term -> do - E.orderBy [E.desc $ term E.^. TermStart ] + -- 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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 2f67bf522..76a988ddb 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -3,6 +3,7 @@ , RecordWildCards , OverloadedStrings , TemplateHaskell + , QuasiQuotes , LambdaCase , ViewPatterns #-} @@ -116,10 +117,13 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do mapM_ (addMessageI "warning") errs - rows <- runDB $ E.select sqlQuery' + (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64))) bool return (sendResponse <=< tblLayout) psShortcircuit $ do - encodeCellTable dbtAttrs' dbtColonnade rows + let table = encodeCellTable dbtAttrs' dbtColonnade rows + $(widgetFile "table-layout") where tblLayout :: Widget -> Handler Html - tblLayout = widgetToPageContent >=> (\tbl -> withUrlRenderer $(hamletFile "templates/table-layout.hamlet")) + tblLayout tbl' = do + tbl <- widgetToPageContent tbl' + withUrlRenderer $(hamletFile "templates/table-layout-wrapper.hamlet") diff --git a/templates/table-layout-wrapper.hamlet b/templates/table-layout-wrapper.hamlet new file mode 100644 index 000000000..34b53ce1f --- /dev/null +++ b/templates/table-layout-wrapper.hamlet @@ -0,0 +1 @@ +^{pageBody tbl} diff --git a/templates/table-layout.hamlet b/templates/table-layout.hamlet index 34b53ce1f..323be24bb 100644 --- a/templates/table-layout.hamlet +++ b/templates/table-layout.hamlet @@ -1 +1,4 @@ -^{pageBody tbl} +
+ ^{table} +

+ _{MsgPage (succ psPage) (succ $ div rowCount psLimit)} From 170442cff0c476d8e81df9a770c87801b0fce017 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 16 Mar 2018 14:22:33 +0100 Subject: [PATCH 3/5] Fix page indicator --- src/Handler/Utils/Table/Pagination.hs | 3 +++ templates/table-layout.hamlet | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 76a988ddb..f00426e45 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -25,6 +25,8 @@ import Yesod.Colonnade import Text.Hamlet (hamletFile) +import Data.Ratio ((%)) + data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) } data SortDirection = SortAsc | SortDesc @@ -121,6 +123,7 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do bool return (sendResponse <=< tblLayout) psShortcircuit $ do let table = encodeCellTable dbtAttrs' dbtColonnade rows + pageCount = max 1 . ceiling $ rowCount % psLimit $(widgetFile "table-layout") where tblLayout :: Widget -> Handler Html diff --git a/templates/table-layout.hamlet b/templates/table-layout.hamlet index 323be24bb..d268dad12 100644 --- a/templates/table-layout.hamlet +++ b/templates/table-layout.hamlet @@ -1,4 +1,4 @@

^{table}

- _{MsgPage (succ psPage) (succ $ div rowCount psLimit)} + _{MsgPage (succ psPage) pageCount} From 28d9c5c95bc1acd00459bf791e8143dcfb08d247 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 19 Mar 2018 12:29:55 +0100 Subject: [PATCH 4/5] Cleanup --- src/Handler/Utils/Table/Pagination.hs | 41 ++++++++++++++++++--------- 1 file changed, 27 insertions(+), 14 deletions(-) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index f00426e45..28fcb1073 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -8,7 +8,13 @@ , ViewPatterns #-} -module Handler.Utils.Table.Pagination where +module Handler.Utils.Table.Pagination + ( SortColumn(..), SortDirection(..) + , DBTable(..) + , PaginationSettings(..) + , PSValidator(..) + , dbTable + ) where import Import import qualified Database.Esqueleto as E @@ -16,9 +22,12 @@ import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) import Text.Blaze (Attribute) import qualified Text.Blaze.Html5.Attributes as Html5 +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_) -import Data.Map (Map) +import Data.Map (Map, (!)) import Colonnade hiding (bool, fromMaybe) import Yesod.Colonnade @@ -29,8 +38,16 @@ import Data.Ratio ((%)) data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) } + data SortDirection = SortAsc | SortDesc deriving (Eq, Ord, Enum, Show, Read) +instance PathPiece SortDirection where + toPathPiece SortAsc = "asc" + toPathPiece SortDesc = "desc" + fromPathPiece (CI.mk -> t) + | t == "asc" = Just SortAsc + | t == "desc" = Just SortDesc + | otherwise = Nothing sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy sqlSortDirection (SortColumn e, SortAsc ) = E.asc e @@ -49,7 +66,7 @@ data DBTable = forall a r h i. } data PaginationSettings = PaginationSettings - { psSorting :: [(SortColumn, SortDirection)] + { psSorting :: [(Text, SortDirection)] , psLimit :: Int64 , psPage :: Int64 , psShortcircuit :: Bool @@ -78,16 +95,11 @@ dbTable :: PSValidator -> DBTable -> Handler Widget dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do let sortingOptions = mkOptionList - [ Option t' (c, d) t' - | (t, c) <- mapToList dbtSorting + [ Option t' (t, d) t' + | (t, _) <- mapToList dbtSorting , d <- [SortAsc, SortDesc] - , let t' = t <> "-" <> tshow d + , let t' = t <> "-" <> toPathPiece 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 (_, defPS) = runPSValidator Nothing wIdent n | not $ null dbtIdent = dbtIdent <> "-" <> n @@ -97,7 +109,7 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do | otherwise = dbtAttrs psResult <- runInputGetResult $ PaginationSettings - <$> ireq sortingField (wIdent "sorting") + <$> ireq (multiSelectField $ return sortingOptions) (wIdent "sorting") <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize")) <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) <*> ireq checkBoxField (wIdent "table-only") @@ -112,13 +124,14 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do FormSuccess ps -> runPSValidator $ Just ps FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing FormMissing -> runPSValidator Nothing + psSorting' = map (first (dbtSorting !)) psSorting sqlQuery' = dbtSQLQuery - <* E.orderBy (map sqlSortDirection psSorting) + <* E.orderBy (map sqlSortDirection psSorting') <* E.limit psLimit <* E.offset (psPage * psLimit) mapM_ (addMessageI "warning") errs - + (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64))) bool return (sendResponse <=< tblLayout) psShortcircuit $ do From 5af34861be472cd167372a8b2d0e112a8d814202 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 3 Apr 2018 16:50:08 +0200 Subject: [PATCH 5/5] fill-db corrected --- fill-db.hs | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/fill-db.hs b/fill-db.hs index dd8f42c62..cc16924c7 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -75,9 +75,10 @@ main = db $ do void . insert $ UserLecturer gkleen ifi void . insert $ UserLecturer fhamann ifi void . insert $ UserLecturer jost ifi - ifiBsc <- insert $ Degree "Bachelor Informatik" ifi - ifiMsc <- insert $ Degree "Master Informatik" ifi - miBsc <- insert $ Degree "Bachelor Mathematik" mi + sdBsc <- insert $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) + sdMst <- insert $ StudyDegree 88 (Just "MSc") (Just "Master" ) + sdInf <- insert $ StudyTerms 79 (Just "Inf") (Just "Informatik") + sdMath <- insert $ StudyTerms 105 (Just "M" ) (Just "Mathematik") -- FFP ffp <- insert Course { courseName = "Fortgeschrittene Funktionale Programmierung" @@ -92,8 +93,9 @@ main = db $ do , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) } insert_ $ CourseEdit jost now ffp - void . insert $ DegreeCourse ifiBsc ffp - void . insert $ DegreeCourse ifiMsc ffp + void . insert $ DegreeCourse ffp sdBsc sdInf + void . insert $ DegreeCourse ffp sdMst sdInf + void . insert $ Lecturer jost ffp void . insert $ Lecturer gkleen ffp insert_ $ Corrector gkleen ffp (ByProportion 1) sheetkey <- insert $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing @@ -112,8 +114,7 @@ main = db $ do , courseRegisterTo = Nothing } insert_ $ CourseEdit fhamann now eip - void . insert $ DegreeCourse ifiBsc eip - void . insert $ DegreeCourse ifiMsc eip + void . insert $ DegreeCourse eip sdBsc sdInf void . insert $ Lecturer fhamann eip -- interaction design ixd <- insert Course @@ -129,7 +130,7 @@ main = db $ do , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) } insert_ $ CourseEdit fhamann now ixd - void . insert $ DegreeCourse ifiBsc ixd + void . insert $ DegreeCourse ixd sdBsc sdInf void . insert $ Lecturer fhamann ixd -- concept development ux3 <- insert Course @@ -145,7 +146,7 @@ main = db $ do , courseRegisterTo = Nothing } insert_ $ CourseEdit fhamann now ux3 - void . insert $ DegreeCourse ifiBsc ux3 + void . insert $ DegreeCourse ux3 sdBsc sdInf void . insert $ Lecturer fhamann ux3 -- promo pmo <- insert Course @@ -161,7 +162,7 @@ main = db $ do , courseRegisterTo = Nothing } insert_ $ CourseEdit jost now pmo - void . insert $ DegreeCourse ifiBsc pmo + void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo -- datenbanksysteme dbs <- insert Course @@ -177,6 +178,7 @@ main = db $ do , courseRegisterTo = Nothing } insert_ $ CourseEdit gkleen now dbs - void . insert $ DegreeCourse ifiBsc dbs + void . insert $ DegreeCourse dbs sdBsc sdInf + void . insert $ DegreeCourse dbs sdBsc sdMath void . insert $ Lecturer gkleen dbs void . insert $ Lecturer jost dbs