From 1787dc1dcb6867391c04f5df2a665b05cf44dd7b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Jul 2018 18:08:47 +0200 Subject: [PATCH] Convert CourseListR to dbTable --- messages/de.msg | 4 ++ models | 2 +- src/Handler/Course.hs | 93 ++++++++++++++++++++++++------------------- 3 files changed, 58 insertions(+), 41 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index 9bb712c15..d78acf450 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -179,3 +179,7 @@ FileCorrectedDeleted: Korrigiert (gelöscht) RatingUpdated: Korrektur gespeichert RatingDeleted: Korrektur zurückgesetzt RatingFilesUpdated: Korrigierte Dateien überschrieben + +CourseMembers: Teilnehmer +CourseMembersCount num@Int64: #{display num} +CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} \ No newline at end of file diff --git a/models b/models index 68d38cb4a..90b554663 100644 --- a/models +++ b/models @@ -60,7 +60,7 @@ Course shorthand Text term TermId school SchoolId - capacity Int Maybe + capacity Int64 Maybe -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index a114a0484..bebf18334 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} module Handler.Course where @@ -19,7 +20,9 @@ import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 import Colonnade hiding (fromMaybe,bool) -import Yesod.Colonnade +-- import Yesod.Colonnade + +import qualified Database.Esqueleto as E import qualified Data.UUID.Cryptographic as UUID @@ -37,45 +40,55 @@ getTermCurrentR = do getTermCourseListR :: TermId -> Handler Html -getTermCourseListR tidini = do - (term,courses) <- runDB $ (,) - <$> get tidini - <*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand] - when (isNothing term) $ do - addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |] - redirect TermShowR - -- TODO: several runDBs per TableRow are probably too inefficient! - let colonnadeTerms = mconcat - [ headed "Kürzel" $ (\ckv -> - let c = entityVal ckv - shd = courseShorthand c - tid = courseTerm c - in [whamlet| #{shd} |] ) --- , headed "Institut" $ [shamlet| #{course} |] - , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal - , headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal - , headed "Teilnehmer" $ (\ckv -> do - let cid = entityKey ckv - partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourse ==. cid] - [whamlet| #{show partiNum} |] - ) - , headed " " $ (\ckv -> - let c = entityVal ckv - shd = courseShorthand c - tid = courseTerm c - in do - adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False - -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CEditR tid shd) else "" - [whamlet| - $if adminLink == Authorized - - editieren - |] - ) +getTermCourseListR tid = do + void . runDB $ get404 tid -- Just ensure the term exists + + let + tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value Int64)) + tableData course = do + E.where_ $ course E.^. CourseTerm E.==. E.val tid + let + participants = E.sub_select . E.from $ \courseParticipant -> do + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + return (E.countRows :: E.SqlExpr (E.Value Int64)) + return (course, participants) + psValidator = def + & defaultSorting [("shorthand", SortAsc)] + + coursesTable <- dbTable psValidator $ DBTable + { dbtSQLQuery = tableData + , dbtColonnade = widgetColonnade $ mconcat + [ sortable (Just "shorthand") (textCell MsgCourse) $ anchorCell' + (\(Entity _ Course{..}, _) -> CourseR courseTerm courseShorthand CShowR) + (\(Entity _ Course{..}, _) -> toWidget courseShorthand) + , sortable (Just "register-from") (textCell MsgRegisterFrom) $ \(Entity _ Course{..}, _) -> textCell $ display courseRegisterFrom + , sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> textCell $ display courseRegisterTo + , sortable (Just "members") (textCell MsgCourseMembers) $ \(Entity _ Course{..}, E.Value num) -> textCell $ case courseCapacity of + Nothing -> MsgCourseMembersCount num + Just max -> MsgCourseMembersCountLimited num max ] - let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses + , dbtSorting = [ ( "shorthand" + , SortColumn $ \course -> course E.^. CourseShorthand + ) + , ( "register-from" + , SortColumn $ \course -> course E.^. CourseRegisterFrom + ) + , ( "register-to" + , SortColumn $ \course -> course E.^. CourseRegisterTo + ) + , ( "members" + , SortColumn $ \course -> E.sub_select . E.from $ \courseParticipant -> do + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + return (E.countRows :: E.SqlExpr (E.Value Int64)) + ) + ] + , dbtFilter = [] + , dbtAttrs = tableDefault + , dbtIdent = "courses" :: Text + } + defaultLayout $ do - setTitleI . MsgTermCourseListTitle $ tidini + setTitleI . MsgTermCourseListTitle $ tid $(widgetFile "courses") getCShowR :: TermId -> Text -> Handler Html @@ -129,7 +142,7 @@ postCRegisterR tid csh = do actTime <- liftIO $ getCurrentTime regOk <- runDB $ do reg <- count [CourseParticipantCourse ==. cid] - if NTop (Just reg) < NTop (courseCapacity course) + if NTop (Just $ fromIntegral reg) < NTop (courseCapacity course) then -- current capacity has room insertUnique $ CourseParticipant cid aid actTime else do -- no space left @@ -260,7 +273,7 @@ data CourseForm = CourseForm , cfShort :: Text , cfTerm :: TermId , cfSchool :: SchoolId - , cfCapacity :: Maybe Int + , cfCapacity :: Maybe Int64 , cfSecret :: Maybe Text , cfMatFree :: Bool , cfRegFrom :: Maybe UTCTime