-- SPDX-FileCopyrightText: 2024 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only module Handler.School.DayTasks ( getSchoolDayR, postSchoolDayR ) where import Import import Handler.Utils import Handler.Utils.Company import Handler.Utils.Occurrences 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.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 {- More efficient DB-only version, but ignores regular schedules getDayTutorials :: SchoolId -> Day -> DB [TutorialId] getDayTutorials ssh d = E.unValue <<$>> E.select (do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) E.where_ $ E.between (E.val d) (trm E.^. TermStart, trm E.^. TermEnd) E.&&. crs E.^. CourseSchool E.==. E.val ssh E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d)) return $ tut E.^. TutorialId ) -} -- Datatype to be used for memcaching occurrences data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day) deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Hashable, Binary) getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] getDayTutorials ssh _dlimit@(dstart, dend ) | dstart > dend = return mempty | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ candidates <- E.select $ do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) E.where_ $ crs E.^. CourseSchool E.==. E.val ssh E.&&. trm E.^. TermStart E.<=. E.val dend E.&&. trm E.^. TermEnd E.>=. E.val dstart return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart)) $logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates return $ mapMaybe checkCandidate candidates where period = Set.fromAscList [dstart..dend] -- TODO: checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- common case checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}},_) | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ = Just tutId | otherwise = Nothing type DailyTableExpr = ( E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Tutorial) `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) `E.InnerJoin` E.SqlExpr (Entity User) ) type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId))) type DailyTableData = DBRow (Entity Course, Entity Tutorial, Entity TutorialParticipant, Entity User, E.Value (Maybe CompanyId)) queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) queryCourse = $(sqlIJproj 4 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) queryTutorial = $(sqlIJproj 4 2) queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant) queryParticipant = $(sqlIJproj 4 3) queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlIJproj 4 4) resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 resultTutorial :: Lens' DailyTableData (Entity Tutorial) resultTutorial = _dbrOutput . _2 resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant) resultParticipant = _dbrOutput . _3 -- resultCompanyId :: Traversal' DailyTableData CompanyId -- resultCompanyId = _dbrOutput . _3 . _entityVal . _tutorialParticipantCompany . _Just resultUser :: Lens' DailyTableData (Entity User) resultUser = _dbrOutput . _4 resultCompanyId :: Traversal' DailyTableData CompanyId resultCompanyId = _dbrOutput . _5 . _unValue . _Just instance HasEntity DailyTableData User where hasEntity = resultUser instance HasUser DailyTableData where hasUser = resultUser . _entityVal mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do tuts <- getDayTutorials ssh (nd,nd) let dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts return (crs, tut, tpu, usr, selectCompanyUserPrime usr) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId dbtColonnade = mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) sortable (Just "course") (i18nCell MsgFilterCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh} = row ^. resultCourse . _entityVal tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin ] dbtSorting = Map.fromList [ sortUserNameLink queryUser , sortUserMatriclenr queryUser , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser , fltrUserMatriclenr queryUser , ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) , ("user-company" , FilterColumn . E.mkContainsFilter $ queryUser >>> selectCompanyUserPrime) ] 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) , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany) , fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev ] 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 "user-name", SortAscBy "course", SortAscBy "tutorial"] over _1 postprocess <$> dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR = postSchoolDayR postSchoolDayR ssh nd = do isAdmin <- hasReadAccessTo AdminR dday <- formatTime SelFormatDate nd (_,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do setTitleI (MsgMenuSchoolDay ssh dday) [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} ^{tableDaily} |]