From 5a03d1cabebd77bd203149ebca8649df7118b07e Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 12 Sep 2024 17:46:38 +0200 Subject: [PATCH] chore(daily): improve stub #90 change DB to JSONB (WIP) --- .../categories/school/de-de-formal.msg | 4 +- messages/uniworx/categories/school/en-eu.msg | 4 +- .../utils/navigation/menu/de-de-formal.msg | 2 +- .../uniworx/utils/navigation/menu/en-eu.msg | 2 +- routes | 2 +- src/Foundation/Navigation.hs | 46 ++++-- src/Handler/School/DayTasks.hs | 139 ++++++++++++++++-- test/Database/Fill.hs | 10 ++ 8 files changed, 177 insertions(+), 32 deletions(-) diff --git a/messages/uniworx/categories/school/de-de-formal.msg b/messages/uniworx/categories/school/de-de-formal.msg index eedea789f..9d678454f 100644 --- a/messages/uniworx/categories/school/de-de-formal.msg +++ b/messages/uniworx/categories/school/de-de-formal.msg @@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Bitte in sowohl deutscher als auch SchoolAuthorshipStatementSheetExamDefinition: Eigenständigkeitserklärung für prüfungszugehörige Übungsblattabgaben SchoolAuthorshipStatementSheetExamDefinitionTip: Bitte in sowohl deutscher als auch englischer Sprache angeben. SchoolAuthorshipStatementSheetAllowOther: Abweichende Eigenständigkeitserklärungen für nicht-prüfungszugehörige Übungsblätter erlauben? -SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben? \ No newline at end of file +SchoolAuthorshipStatementSheetExamAllowOther: Abweichende Eigenständigkeitserklärungen für prüfungszugehörige Übungsblätter erlauben? + +DailyActDummy: Platzhalter ohne Funktion \ No newline at end of file diff --git a/messages/uniworx/categories/school/en-eu.msg b/messages/uniworx/categories/school/en-eu.msg index 32109bfa4..5f2a79667 100644 --- a/messages/uniworx/categories/school/en-eu.msg +++ b/messages/uniworx/categories/school/en-eu.msg @@ -40,4 +40,6 @@ SchoolAuthorshipStatementSheetDefinitionTip: Please enter both german and englis SchoolAuthorshipStatementSheetExamDefinition: Statement of Authorship for exam-related exercise sheets SchoolAuthorshipStatementSheetExamDefinitionTip: Please enter both german and english statements. SchoolAuthorshipStatementSheetAllowOther: Allow adaptations for exam-unrelated exercise sheets? -SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets? \ No newline at end of file +SchoolAuthorshipStatementSheetExamAllowOther: Allow adaptations for exam-related exercise sheets? + +DailyActDummy: Placholder without function \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 2f6e7f48e..ae3990d41 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -97,7 +97,7 @@ MenuExamOfficeUsers: Benutzer:innen MenuLecturerInvite: Funktionäre hinzufügen MenuSchoolList: Bereiche MenuSchoolNew: Neuen Bereich anlegen -MenuSchoolDay d@Text: #{d} Tagesansicht +MenuSchoolDay ssh@SchoolId d@Text: #{unSchoolKey ssh} #{d} Tagesansicht MenuExternalExamGrades: Prüfungsleistungen MenuExternalExamUsers: Teilnehmer:innen MenuExternalExamEdit: Bearbeiten diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c7e4eb0f8..c8775ef4e 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -97,7 +97,7 @@ MenuExamOfficeUsers: Users MenuLecturerInvite: Add functionaries MenuSchoolList: Departments MenuSchoolNew: Create new department -MenuSchoolDay d@Text: #{d} Day +MenuSchoolDay ssh d: #{unSchoolKey ssh} #{d} Day MenuExternalExamGrades: Exam results MenuExternalExamUsers: Participants MenuExternalExamEdit: Edit diff --git a/routes b/routes index c6aa0743e..64b459813 100644 --- a/routes +++ b/routes @@ -154,7 +154,7 @@ !/term/#TermId/#SchoolId TermSchoolCourseListR GET !free -/school SchoolListR GET +/school SchoolListR GET !free !/school/new SchoolNewR GET POST /school/#SchoolId SchoolR: /edit SchoolEditR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 5fe8c6c3d..0bf6d5306 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -149,10 +149,10 @@ breadcrumb (SchoolR ssh SchoolEditR) = School{..} <- MaybeT $ get ssh isAdmin <- lift $ hasReadAccessTo SchoolListR return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin) -breadcrumb (SchoolR _ssh (SchoolDayR d)) = do +breadcrumb (SchoolR ssh (SchoolDayR d)) = do dt <- formatTime SelFormatDate d mr <- getMessageRender - return (mr $ MsgMenuSchoolDay dt, Just SchoolListR) + return (mr $ MsgMenuSchoolDay ssh dt, Just SchoolListR) breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing @@ -941,19 +941,37 @@ pageActions :: ( MonadHandler m , MonadUnliftIO m ) => Route UniWorX -> m [Nav] -pageActions NewsR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuOpenCourses - , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) - , navAccess' = NavAccessTrue - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False +pageActions NewsR = do + now <- liftIO getCurrentTime + let nowaday = utctDay now + nd <- formatTime SelFormatDate now + schools <- useRunDB $ selectList [] [Asc SchoolShorthand] + return $ + ( NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuOpenCourses + , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] } - , navChildren = [] - } - ] + ) : + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSchoolDay ssh nd + , navRoute = SchoolR ssh $ SchoolDayR nowaday + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + | sch <- schools, let ssh = sch ^. _entityKey + ] pageActions (CourseR tid ssh csh CShowR) = do materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 15fd0003f..2b99929d1 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -11,26 +11,139 @@ module Handler.School.DayTasks import Import --- import Handler.Utils +import Handler.Utils --- import qualified Data.Set as Set --- import qualified Data.Map as Map --- import qualified Data.Aeson as Aeson +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) --- import Database.Esqueleto.Experimental ((:&)(..)) --- -- import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy --- import qualified Database.Esqueleto.Experimental as E --- import qualified Database.Esqueleto.Utils as E --- import Database.Esqueleto.Utils.TH +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy +import qualified Database.Esqueleto.Experimental as E +import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH +import Database.Esqueleto.PostgreSQL.JSON as E +data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe DailyTableAction +instance Finite DailyTableAction +nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''DailyTableAction id + +data DailyTableActionData = DailyActDummyData + deriving (Eq, Ord, Read, Show, Generic) + +-- | partial JSON object to be used for filtering with "@>" +occurrenceDayValue :: Day -> Value +occurrenceDayValue d = Aeson.object + [ "exceptions" Aeson..= + [ Aeson.object + [ "exception" Aeson..= ("occur"::Text) + , "day" Aeson..= d + ] ] ] +-- TODO: ensure that an appropriate GIN index for the jsonb column is set + + + +type DailyTableExpr = + ( E.SqlExpr (Entity Course) + `E.InnerJoin` E.SqlExpr (Entity Tutorial) + ) + +queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) +queryCourse = $(sqlIJproj 2 1) + + +queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) +queryTutorial = $(sqlIJproj 2 2) + + +type DailyTableData = DBRow (Entity Course, Entity Tutorial) + +resultCourse :: Lens' DailyTableData (Entity Course) +resultCourse = _dbrOutput . _1 + +resultTutorial :: Lens' DailyTableData (Entity Tutorial) +resultTutorial = _dbrOutput . _2 + + +mkDailyTable :: SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) +mkDailyTable ssh nd = do + let + dbtSQLQuery :: DailyTableExpr -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial)) + dbtSQLQuery (course `E.InnerJoin` tut) = do + EL.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse + E.where_ $ course E.^. CourseSchool E.==. E.val ssh + E.&&. ((tut E.^. TutorialTime) @>. (E.jsonbVal $ occurrenceDayValue nd) + ) + return (course, tut) + dbtRowKey = queryTutorial >>> (E.^. TutorialId) + dbtProj = dbtProjId + dbtColonnade = mconcat + [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) + sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal . _courseName . _CI -> t) -> textCell t + , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \(view $ resultTutorial . _entityVal . _tutorialName . _CI -> t) -> textCell t + ] + dbtSorting = Map.fromList + [ ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) + ] + dbtFilter = Map.fromList + [ ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) + , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) + ] + dbtFilterUI mPrev = mconcat + [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) + , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) + + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} + dbtIdent :: Text + dbtIdent = "daily" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormNoSubmit + , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty) + -- , dbParamsFormSubmit = FormSubmit + -- , dbParamsFormAdditional + -- = let acts :: Map MCTableAction (AForm Handler MCTableActionData) + -- acts = mconcat + -- [ singletonMap MCActDummy $ pure MCActDummyData + -- ] + -- in renderAForm FormStandard + -- $ (, mempty) . First . Just + -- <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialId Bool DailyTableData) + -> FormResult ( DailyTableActionData, Set TutorialId) + postprocess inp = do + (First (Just act), jobMap) <- inp + let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + return (act, jobSet) + psValidator = def & defaultSorting [SortAscBy "course", SortAscBy "tutorial"] + over _1 postprocess <$> dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR = postSchoolDayR -postSchoolDayR _ssh _day = do - siteLayout "TODO" $ do - setTitle "Day Tasks" - [whamlet|TODO|] +postSchoolDayR ssh nd = do + dday <- formatTime SelFormatDate nd + tableDaily <- runDB $ mkDailyTable ssh nd + siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do + setTitleI (MsgMenuSchoolDay ssh dday) + [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} + ^{tableDaily} + |] diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 6827257e6..525d6b290 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1087,6 +1087,11 @@ fillDb = do , exceptStart = TimeOfDay 9 0 0 , exceptEnd = TimeOfDay 16 0 0 } + , ExceptOccur + { exceptDay = nowaday + , exceptStart = TimeOfDay 9 10 0 + , exceptEnd = TimeOfDay 16 10 0 + } ] } , tutorialRegGroup = Just "Schulung" @@ -1128,6 +1133,11 @@ fillDb = do , exceptStart = TimeOfDay 10 12 0 , exceptEnd = TimeOfDay 12 13 0 } + , ExceptOccur + { exceptDay = nowaday + , exceptStart = TimeOfDay 17 10 0 + , exceptEnd = TimeOfDay 18 10 0 + } ] } , tutorialRegGroup = Just "schulung"