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/Term.hs b/src/Handler/Term.hs index 39642135a..3eee14c4e 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,27 +51,33 @@ 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 + , dbtIdent = "terms" :: Text + } defaultLayout $ do setTitle "Freigeschaltete Semester" - encodeWidgetTable tableSortable colonnadeTerms termData - + table getTermEditR :: Handler Html getTermEditR = do diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 916132b62..ad204b33a 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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs new file mode 100644 index 000000000..428810362 --- /dev/null +++ b/src/Handler/Utils/Table/Pagination.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , RecordWildCards + , OverloadedStrings + , TemplateHaskell + , LambdaCase + , ViewPatterns + #-} + +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 Control.Monad.RWS hiding ((<>), Foldable(..), mapM_) + +import Data.Map (Map) + +import Colonnade hiding (bool, fromMaybe) +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 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 + { psSorting :: [(SortColumn, SortDirection)] + , psLimit :: Int64 + , psPage :: Int64 + , psShortcircuit :: Bool + } + +instance Default PaginationSettings where + def = PaginationSettings + { psSorting = [] + , psLimit = 50 + , psPage = 0 + , psShortcircuit = False + } + +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{ dbtIdent = (toPathPiece -> dbtIdent), .. } = 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 + (_, defPS) = runPSValidator Nothing + wIdent n + | not $ null dbtIdent = dbtIdent <> "-" <> n + | otherwise = n + + psResult <- runInputGetResult $ PaginationSettings + <$> 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) + <*> (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 + sqlQuery' = dbtSQLQuery + <* E.orderBy (map sqlSortDirection psSorting) + <* E.limit psLimit + <* E.offset (psPage * psLimit) + + mapM_ (addMessageI "warning") errs + + 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}