-- 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.Experimental as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.PostgreSQL.JSON ((@>.)) import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.)) import Database.Esqueleto.Utils.TH 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 "@>" -- ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions occurrenceDayValue :: Day -> Value occurrenceDayValue d = Aeson.object [ "exceptions" Aeson..= [ Aeson.object [ "exception" Aeson..= ("occur"::Text) , "day" Aeson..= d ] ] ] {- 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 $ 12 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $ do 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] checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most 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 -- Datatype to be used for memcaching occurrences data LessonCacheKey = LessonCacheKeyTutorials SchoolId (Day,Day) deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Hashable, Binary) -- | like getDayTutorials, but also returns the lessons occurring within the given time frame getDayTutorials' :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime]) getDayTutorials' ssh dlimit@(dstart, dend ) | dstart > dend = return mempty | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (LessonCacheKeyTutorials ssh dlimit) $ do 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) -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates return $ foldMap checkCandidate candidates where checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId [LessonTime] checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}) | let lessons = Set.filter lessonFltr $ occurringLessons trm occ , notNull lessons = Map.singleton tutId $ Set.toAscList lessons -- due to Set not having a Functor instance, we need mostly need lists anyway | otherwise = mempty lessonFltr :: LessonTime -> Bool lessonFltr LessonTime{..} = dstart <= localDay lessonStart && dend >= localDay lessonEnd type DailyTableExpr = ( E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Tutorial) `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) `E.InnerJoin` E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserAvs)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserDay)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity TutorialParticipantDay)) ) type DailyTableOutput = E.SqlQuery ( E.SqlExpr (Entity Course) , E.SqlExpr (Entity Tutorial) , E.SqlExpr (Entity TutorialParticipant) , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity UserAvs)) , E.SqlExpr (Maybe (Entity UserDay)) , E.SqlExpr (Maybe (Entity TutorialParticipantDay)) , E.SqlExpr (E.Value (Maybe CompanyId)) , E.SqlExpr (E.Value (Maybe [QualificationId])) ) type DailyTableData = DBRow ( Entity Course , Entity Tutorial , Entity TutorialParticipant , Entity User , Maybe (Entity UserAvs) , Maybe (Entity UserDay) , Maybe (Entity TutorialParticipantDay) , E.Value (Maybe CompanyId) , E.Value (Maybe [QualificationId]) ) -- force declarations before this point to avoid staging restrictions $(return []) queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) queryCourse = $(sqlMIXproj' ''DailyTableExpr 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2) queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant) queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now -- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlMIXproj' ''DailyTableExpr 4) queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs)) queryUserAvs = $(sqlMIXproj' ''DailyTableExpr 5) queryUserDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserDay)) queryUserDay = $(sqlMIXproj' ''DailyTableExpr 6) queryParticipantDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity TutorialParticipantDay)) queryParticipantDay = $(sqlMIXproj' ''DailyTableExpr 7) resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 resultTutorial :: Lens' DailyTableData (Entity Tutorial) resultTutorial = _dbrOutput . _2 resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant) resultParticipant = _dbrOutput . _3 resultUser :: Lens' DailyTableData (Entity User) resultUser = _dbrOutput . _4 resultUserAvs :: Traversal' DailyTableData UserAvs resultUserAvs = _dbrOutput . _5 . _Just . _entityVal resultUserDay :: Traversal' DailyTableData UserDay resultUserDay = _dbrOutput . _6 . _Just . _entityVal resultParticipantDay :: Traversal' DailyTableData TutorialParticipantDay resultParticipantDay = _dbrOutput . _7 . _Just . _entityVal resultCompanyId :: Traversal' DailyTableData CompanyId resultCompanyId = _dbrOutput . _8 . _unValue . _Just resultCourseQualis :: Traversal' DailyTableData [QualificationId] resultCourseQualis = _dbrOutput . _9 . _unValue . _Just instance HasEntity DailyTableData User where hasEntity = resultUser instance HasUser DailyTableData where hasUser = resultUser . _entityVal -- see colRatedField' for an example of formCell usage drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit drivingPermitField = selectField' Nothing optionsFinite -- eyeExamField :: Field (HandlerFor UniWorX) UserEyeExam -- eyeExamField = selectField optionsFinite -- This does not type: -- colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -- colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table -- (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result -- (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> -- over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") $ Just x -- ) -- Given the row data and a callback to make an input name suitably unique generate the MForm -- colEyeExamField :: TODO colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note) ) -- Given the row data and a callback to make an input name suitably unique generate the MForm colAttendanceField :: Text -> ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colAttendanceField dday l = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance ) -- Given the row data and a callback to make an input name suitably unique generate the MForm colAttendnaceNoteField :: Text -> ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colAttendnaceNoteField dday l = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique -> over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note) ) -- Given the row data and a callback to make an input name suitably unique generate the MForm colParkingField :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colParkingField l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking ) -- Given the row data and a callback to make an input name suitably unique generate the MForm mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do tutLessons <- getDayTutorials' ssh (nd,nd) dday <- formatTime SelFormatDate nd let tutIds = Map.keys tutLessons dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser E.&&. E.val nd E.=?. udy E.?. UserDayDay EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId let cqQual = cq E.^. CourseQualificationQualification cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual] return $ E.arrayAggWith E.AggModeAll cqQual cqOrder return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications) dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId) 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 Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False) $ Map.lookup tutId tutLessons , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) -> -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ Map.lookup tutId tutLessons -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell , 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 , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell -- , colParkingField id ] 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)) , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo)) , ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit)) , ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam)) , ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote)) , ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance)) , ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote)) , ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken)) ] 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} |]