-- 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 -- | Maximal number of suggestions for note fields in Day Task view maxSuggestions :: Int64 maxSuggestions = 7 -- 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]) ) data DailyFormData = DailyFormData { dailyFormDrivingPermit :: Maybe UserDrivingPermit , dailyFormEyeExam :: Maybe UserEyeExam , dailyFormParticipantNote :: Maybe Text , dailyFormAttendance :: Bool , dailyFormAttendanceNote :: Maybe Text , dailyFormParkingToken :: Bool } deriving (Eq, Show) makeLenses_ ''DailyFormData -- 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' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam eyeExamField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite mkDailyFormColumn :: (RenderMessage UniWorX msg) => Text -> msg -> Lens' DailyTableData a -> ASetter' DailyFormData a -> Field _ a -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ 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 lg -> x) mkUnique -> over (_1.mapped) (ls .~) . over _2 fvWidget <$> mreq f (fsUniq mkUnique k) (Just x) ) -- Given the row data and a callback to make an input name suitably unique generate the MForm colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> 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" & addClass' "uwx-narrow") (Just x) ) -- Given the row data and a callback to make an input name suitably unique generate the MForm colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam" & addClass' "uwx-narrow") (Just x) ) -- colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -- colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- (views (resultParticipant . _entityKey) return) -- (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> -- over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> -- mopt textareaField (fsUniq mkUnique "note-tutorial") (Just $ Textarea <$> note) -- ) colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\row mkUnique -> let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote sid = row ^. resultCourse . _entityVal . _courseSchool cid = row ^. resultCourse . _entityKey tid = row ^. resultTutorial . _entityKey in over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> mopt (textField & cfStrip & addDatalist (suggsParticipantNote sid cid tid)) (fsUniq mkUnique "note-tutorial") (Just note) ) suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsParticipantNote sid cid tid = do ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough? suggs <- runDB $ E.select $ do let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows (tpn, prio) <- E.from $ ( do tpa <- E.from $ E.table @TutorialParticipant E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid E.groupBy $ tpa E.^. TutorialParticipantNote E.orderBy [E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantNote, E.val (1 :: Int64)) ) `E.unionAll_` ( do (tpa :& tut) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial) E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid E.&&. tut E.^. TutorialCourse E.==. E.val cid E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote) E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantNote, E.val 2) ) `E.unionAll_` ( do tpa :& tut :& crs <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial) `E.innerJoin` E.table @Course `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId) E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid E.&&. tut E.^. TutorialCourse E.!=. E.val cid E.&&. crs E.^. CourseSchool E.==. E.val sid E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote) E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantNote, E.val 3) ) E.groupBy (tpn, prio) E.orderBy [E.asc prio, E.asc tpn] E.limit maxSuggestions pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type -- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs -- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol pure $ mkOptionListFromCacheable ol suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Textarea) suggsAttendanceNote sid cid tid = do ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough? suggs <- runDB $ E.select $ do let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows (tpn, prio) <- E.from $ ( do tpa <- E.from $ E.table @TutorialParticipantDay E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) E.&&. tpa E.^. TutorialParticipantDayTutorial E.==. E.val tid E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay) E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantDayNote, E.val (1 :: Int64)) -- ) `E.unionAll_` -- ( do -- (tpa :& tut) <- E.from $ E.table @TutorialParticipantDay -- `E.innerJoin` E.table @Tutorial -- `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) -- E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) -- E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid -- E.&&. tut E.^. TutorialCourse E.==. E.val cid -- E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote) -- E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows'] -- E.limit maxSuggestions -- pure (tpa E.^. TutorialParticipantDayNote, E.val 2) -- ) `E.unionAll_` -- ( do -- tpa :& tut :& crs <- E.from $ E.table @TutorialParticipantDay -- `E.innerJoin` E.table @Tutorial -- `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) -- `E.innerJoin` E.table @Course -- `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId) -- E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) -- E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid -- E.&&. tut E.^. TutorialCourse E.!=. E.val cid -- E.&&. crs E.^. CourseSchool E.==. E.val sid -- E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote) -- E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] -- E.limit maxSuggestions -- pure (tpa E.^. TutorialParticipantDayNote, E.val 3) ) E.groupBy (tpn, prio) E.orderBy [E.asc prio, E.asc tpn] E.limit maxSuggestions pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type -- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs pure $ mkOptionListCacheable $ fmap Textarea . mkOptionText <$> nubOrd suggs -- TODO: datalist does not work on textarea inputs! -- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol pure $ mkOptionListFromCacheable ol colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id (views (resultParticipant . _entityKey) return) (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique -> over (_1.mapped) (_dailyFormAttendance .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance ) colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ -- (cellAttrs <>~ [("style","width:10%"), ("style","height:200px")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\row mkUnique -> let note = row ^? resultParticipantDay . _tutorialParticipantDayNote sid = row ^. resultCourse . _entityVal . _courseSchool cid = row ^. resultCourse . _entityKey tid = row ^. resultTutorial . _entityKey in over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt (textareaField & addDatalist (suggsAttendanceNote sid cid tid)) -- TODO: datalist does not work on textarea inputs! (fsUniq mkUnique "note-attendance" & addClass' "uwx-short" -- & addAttr "rows" "2" -- does not work without class uwx-short -- & addAttr "cols" "12" -- let it stretch -- & addAutosubmit -- submits while typing ) (Textarea <<$>> note) ) colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParkingField = colParkingField' _dailyFormParkingToken -- colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -- colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- (views (resultParticipant . _entityKey) return) -- (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> -- over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking -- ) colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id -- TODO: this should not be id! Refactor to simplify the thrid argument below (views (resultParticipant . _entityKey) return) (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking ) mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget) mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case tutLessons | Map.null tutLessons -> return (FormMissing, [whamlet|No tutorials on this day|]) | otherwise -> do 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 = formColonnade $ 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 , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany primComp = row ^? resultCompanyId bookLink = cellMaybe companyIdCell bookComp result | primComp /= bookComp , Just (unCompanyKey -> csh) <- primComp = bookLink <> spacerCell <> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True) | otherwise = bookLink in result -- , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row -> -- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany -- primComp = row ^? resultCompanyId -- bookLink = cellMaybe companyIdCell bookComp -- warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True -- result -- | primComp /= bookComp -- , Just (unCompanyKey -> csh) <- primComp -- = bookLink -- <> spacerCell -- <> cell (modal (warnIcon csh) (Right -- TODO: use iconCompanyWarning instead! -- [whamlet| --

-- ^{userWidget row} --

-- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)} -- |] -- )) -- | otherwise = bookLink -- in result , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn , colParticipantPermitField , colParticipantEyeExamField , colParticipantNoteField , colAttendanceField dday , colAttendanceNoteField dday , colParkingField -- FOR DEBUGGING ONLY -- , 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 ] 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 = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd } -- dbtParams = DBParamsForm -- { dbParamsFormMethod = POST -- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute -- , dbParamsFormAttrs = [] -- , dbParamsFormSubmit = FormSubmit -- , dbParamsFormAdditional = \frag -> do -- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) -- acts = mconcat -- [ singletonMap DailyActDummy $ pure DailyActDummyData -- ] -- (actionRes, action) <- multiActionM acts "" Nothing mempty -- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) -- -- , dbParamsFormAdditional -- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) -- -- acts = mconcat -- -- [ singletonMap DailyActDummy $ pure DailyActDummyData -- -- ] -- -- in renderAForm FormStandard -- -- $ (, mempty) . First . Just -- -- <$> multiActionA acts (fslI MsgTableAction) Nothing -- , dbParamsFormEvaluate = liftHandler . runFormPost -- , dbParamsFormResult = _1 -- , dbParamsFormIdent = def -- } -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId 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{..} dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR = postSchoolDayR postSchoolDayR ssh nd = do isAdmin <- hasReadAccessTo AdminR dday <- formatTime SelFormatDate nd let unFormResult = getDBFormResult $ \row -> let tpt = row ^. resultParticipant . _entityVal in DailyFormData { dailyFormDrivingPermit = tpt ^. _tutorialParticipantDrivingPermit , dailyFormEyeExam = tpt ^. _tutorialParticipantEyeExam , dailyFormParticipantNote = tpt ^. _tutorialParticipantNote , dailyFormAttendance = row ^? resultParticipantDay ._tutorialParticipantDayAttendance & fromMaybe False , dailyFormAttendanceNote = row ^? resultParticipantDay ._tutorialParticipantDayNote . _Just , dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False } (fmap unFormResult -> tableRes,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd $logInfoS "****DailyTable****" $ tshow tableRes formResult tableRes $ \resMap -> do runDB $ do forM_ (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do -- $logDebugS "TableForm" (tshow dfd) TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit || tutorialParticipantEyeExam /= dailyFormEyeExam || tutorialParticipantNote /= dailyFormParticipantNote) $ update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit , TutorialParticipantEyeExam =. dailyFormEyeExam , TutorialParticipantNote =. dailyFormParticipantNote ] let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote) then deleteBy tpdUq else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote) [ TutorialParticipantDayAttendance =. dailyFormAttendance , TutorialParticipantDayNote =. dailyFormAttendanceNote ] let udUq = UniqueUserDay tutorialParticipantUser nd updateUserDay = if dailyFormParkingToken then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] -- audit log? Currently decided against. addMessageI Success $ MsgTutorialParticipantsDayEdits dday redirect $ SchoolR ssh $ SchoolDayR nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do setTitleI (MsgMenuSchoolDay ssh dday) [whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)} ^{tableDaily} |]